From a025434c2b33808025e9c7aa307b1aa179e43b31 Mon Sep 17 00:00:00 2001 From: Corwin Brust Date: Tue, 23 Jun 2026 19:34:36 -0500 Subject: [PATCH] initial commit --- .gitignore | 5 + Makefile | 82 +++ README.org | 83 +++ card-games-pkg.el | 9 + card-games.el | 132 +++++ cg-bid-ui.el | 1082 ++++++++++++++++++++++++++++++++++++++ cg-bid.el | 844 +++++++++++++++++++++++++++++ cg-core.el | 142 +++++ cg-gaps.el | 850 ++++++++++++++++++++++++++++++ cg-svg.el | 381 ++++++++++++++ test/card-games-tests.el | 216 ++++++++ 11 files changed, 3826 insertions(+) create mode 100644 .gitignore create mode 100644 Makefile create mode 100644 README.org create mode 100644 card-games-pkg.el create mode 100644 card-games.el create mode 100644 cg-bid-ui.el create mode 100644 cg-bid.el create mode 100644 cg-core.el create mode 100644 cg-gaps.el create mode 100644 cg-svg.el create mode 100644 test/card-games-tests.el diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..e5f2d10 --- /dev/null +++ b/.gitignore @@ -0,0 +1,5 @@ +*.elc +/dist/ +/card-games-*.tar +/card-games-*-src.tar.gz +*.sketch diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..296ad0c --- /dev/null +++ b/Makefile @@ -0,0 +1,82 @@ +# Makefile for card-games -- byte-compile, test, and package. +EMACS ?= emacs +PKG = card-games +VERSION = 1.0.50 +# Source files in dependency order (cg-core first). +EL = cg-core.el cg-svg.el cg-bid.el cg-gaps.el cg-bid-ui.el card-games.el +ELC = $(EL:.el=.elc) +PKGDESC = $(PKG)-pkg.el +TARDIR = $(PKG)-$(VERSION) +TAR = $(TARDIR).tar +SRCTAR = $(PKG)-$(VERSION)-src.tar.gz +DIST = dist +BATCH = $(EMACS) -Q --batch -L . +EXTRA = README.org $(PKGDESC) + +.PHONY: all compile test clean distclean checkdoc lint package tarball elpa release help + +help: + @echo "card-games $(VERSION) -- make targets:" + @echo " compile byte-compile all sources" + @echo " test run the ERT test suite" + @echo " checkdoc run checkdoc on all sources" + @echo " lint run package-lint (if installed)" + @echo " package build the installable package tarball ($(TAR))" + @echo " elpa build a one-package ELPA archive in $(DIST)/" + @echo " release clean + test + package + source tarball" + @echo " clean remove .elc and build artifacts" + +all: compile + +# Compile in order so each file sees its compiled dependencies. +compile: + $(BATCH) -f batch-byte-compile $(EL) + +test: + $(BATCH) -L test -l test/$(PKG)-tests.el -f ert-run-tests-batch-and-exit + +checkdoc: + $(BATCH) --eval "(progn (dolist (f '($(EL))) (checkdoc-file f)))" + +lint: + -$(BATCH) --eval "(progn (require 'package) (package-initialize) \ + (unless (require 'package-lint nil t) (error \"package-lint not installed\")) \ + (setq package-lint-main-file \"$(PKG).el\") \ + (dolist (f '($(EL))) (with-temp-buffer (insert-file-contents f) \ + (emacs-lisp-mode) (package-lint-buffer))))" + +# Installable multi-file package: card-games-VERSION.tar with a top +# directory of the same name (package.el / package-install-file format). +package: tarball +# Uses GNU tar's --transform to add the top directory without a temp copy. +tarball: $(EL) $(EXTRA) + tar --transform 's,^,$(TARDIR)/,' -cf $(TAR) $(EL) $(EXTRA) + @echo "Built $(TAR)" + +# A minimal ELPA archive (archive-contents + tar) under dist/. +# Testers can: (add-to-list 'package-archives '("cg" . "/path/to/dist/")) +elpa: tarball + rm -rf $(DIST) + mkdir -p $(DIST) + $(BATCH) --eval "(progn (require 'package-x) \ + (let ((package-archive-upload-base (expand-file-name \"$(DIST)\"))) \ + (package-upload-file \"$(TAR)\")))" + @echo "ELPA archive in $(DIST)/" + +# Source snapshot for a GitHub release. Archive an explicit file list +# (not ".") so the growing output tarball and editor lock files are never +# read mid-write -- which is what caused "tar: .: file changed as we read it". +SRCFILES = $(EL) $(EXTRA) Makefile .gitignore test +release: distclean test tarball + rm -f $(SRCTAR) + tar --transform 's,^,$(TARDIR)/,' \ + --exclude='*.elc' --exclude='*.tar' --exclude='*.tar.gz' \ + --exclude='.#*' --exclude='$(DIST)' --exclude='.git' \ + -czf $(SRCTAR) $(SRCFILES) + @echo "Built $(SRCTAR) and $(TAR) for release $(VERSION)" + +clean: + rm -f $(ELC) + +distclean: clean + rm -rf $(DIST) $(TARDIR) $(TAR) $(SRCTAR) diff --git a/README.org b/README.org new file mode 100644 index 0000000..ed498bf --- /dev/null +++ b/README.org @@ -0,0 +1,83 @@ +#+TITLE: card-games -- Play card games in Emacs +#+AUTHOR: Corwin Brust + +Card games for Emacs. + +Renders SVG by default when ~display-graphic-p~ is t and rsvg is +available. The default (UNICODE) symbols maybe customized by +configuring ~card-game-symbols~. + +* Games +- *500 (Bid)* -- the four-handed partnership trick-taking game, against + three computer opponents (=M-x cg-bid=). +- *Gaps / Hell's Half-Acre* -- solitaire; sort each row into one suit + running 2..K (=M-x cg-gaps=). + +To launch the game-menu press =M-x card-game= or launch a game +directly by calling it's launcher command. Launcher commands take the +form ~cg-GAME~ where ~GAME~ is one of +- montana - Montana: +- gap - Gap: +- hha - Hells Half Acre: +- bid - Bid, (or 500 Bid): + +* TODO +- [ ] documentation +- [ ] create ~card-game-symbols~ and obey it +- [ ] refactor to allow games to subclass components (svg) +- [ ] add manual-control silder for card size (svgfull) +- [ ] mor games + +* Install +** From the package tarball +#+begin_src +make package # builds card-games-1.0.50.tar +#+end_src +Then in Emacs: ~M-x package-install-file RET card-games-1.0.50.tar~. + +** From a local ELPA archive +#+begin_src +make elpa # builds dist/ (archive-contents + tar) +#+end_src +#+begin_src emacs-lisp +(add-to-list 'package-archives '("cg" . "/path/to/dist/")) +(package-refresh-contents) +(package-install 'card-games) +#+end_src + +** Manually +Put the ~cg-*.el~ and ~card-games.el~ files on your ~load-path~ and +~(require 'card-games)~. + +* Playing +Both games work with the keyboard everywhere and with the mouse on a +graphical display. + +- 500: ~b~ bid, ~p~ pass, arrows + ~RET~ to play (or click a card), + ~n~ next hand / new game, ~?~ help. +- Gaps: arrows or ~hjkl~ to move, ~RET~ to fill a gap (or click it), + ~r~ redeal, ~u~ undo, ~n~ new, ~?~ help. + +* Customization +~M-x customize-group RET cg-svg~ and ~RET card-games~: +- ~cg-svg-theme-colors~ -- derive the highlight ring and card backs + from your theme (on by default). +- ~cg-bid-felt-color~ -- the 500 table felt. +- ~cg-svg-card-width~, ~cg-svg-card-height~, ~cg-svg-card-shadow~, + ~cg-svg-font-family~ -- card appearance. +- ~cg-svg-card-back~ -- card-back pattern: dots, rings, or solid. +- ~cg-bid-animate~, ~cg-bid-ai-delay~, ~cg-bid-trick-pause~ -- pace the + 500 AI so play is watchable and completed tricks linger. +- ~M-x card-games-set-theme~ -- apply a preset (classic, dark, contrast). + +* Development +#+begin_src +make compile # byte-compile (should be warning-free) +make test # run the ERT suite +make checkdoc # documentation lint +make release # clean + test + package + source tarball +#+end_src + +* License +GPL-3.0-or-later. See the file headers; add a COPYING file with the +full GPLv3 text for distribution. diff --git a/card-games-pkg.el b/card-games-pkg.el new file mode 100644 index 0000000..ba68baa --- /dev/null +++ b/card-games-pkg.el @@ -0,0 +1,9 @@ +;;; card-games-pkg.el --- Package metadata -*- no-byte-compile: t; -*- +(define-package "card-games" "1.0.50" + "Play card games in Emacs (console UNICODE and graphical SVG)." + '((emacs "26.1")) + :keywords '("games") + :url "https://github.com/corwin/card-games" + :authors '(("Corwin Brust" . "corwin@bru.st")) + :maintainer '("Corwin Brust" . "corwin@bru.st")) +;;; card-games-pkg.el ends here diff --git a/card-games.el b/card-games.el new file mode 100644 index 0000000..0cb3315 --- /dev/null +++ b/card-games.el @@ -0,0 +1,132 @@ +;;; card-games.el --- Play card games in Emacs (console + SVG) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Card games for Emacs, rendered as UNICODE text in a terminal and as +;; SVG cards on a graphical display. This file is the umbrella: it +;; pulls in the individual games and offers a chooser. +;; +;; Run `M-x card-game' for a menu, or start a game directly: +;; +;; `cg-bid' -- 500, the four-handed partnership trick-taking game, +;; played against three computer opponents. +;; `cg-gaps' -- Gaps / Montana / "Hell's Half-Acre" solitaire. +;; +;; New games register themselves by adding to `card-games-list'. + +;;; Code: + +(require 'cg-core) +(require 'cg-gaps) +(require 'cg-bid-ui) + +(defvar card-games-list + '(("500 (Bid)" cg-bid + "Four-handed partnership trick-taking versus three AI opponents.") + ("Gaps (Montana)" cg-montana + "Solitaire: a Two anchors each row; build up 2 through King.") + ("Hell's Half-Acre" cg-hells-half-acre + "Solitaire: a King anchors each row; build down King through 2.")) + "Registry of playable games. +Each entry is (NAME COMMAND DESCRIPTION); `card-game' lists them.") + +(defun card-game--launch (button) + "Start the game whose command is stored on BUTTON." + (let ((cmd (button-get button 'card-game-command))) + (quit-window) + (call-interactively cmd))) + +(defvar card-game-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map special-mode-map) + (define-key map "n" #'forward-button) + (define-key map "p" #'backward-button) + (define-key map (kbd "TAB") #'forward-button) + (define-key map (kbd "") #'backward-button) + map) + "Keymap for `card-game-mode'.") + +(define-derived-mode card-game-mode special-mode "Card-Games" + "Major mode for the `card-game' chooser." + (setq-local cursor-type nil)) + +;;;###autoload +(defun card-game () + "Open a chooser listing the available card games. +Press RET (or click) on a game to start it." + (interactive) + (let ((buf (get-buffer-create "*Card Games*"))) + (with-current-buffer buf + (card-game-mode) + (let ((inhibit-read-only t)) + (erase-buffer) + (insert (propertize " Card Games for Emacs\n" 'face 'bold)) + (insert (propertize + " Choose a game with RET or the mouse. q to quit.\n\n" + 'face 'shadow)) + (dolist (g card-games-list) + (insert " ") + (insert-text-button + (format "%-26s" (nth 0 g)) + 'face 'link + 'help-echo (nth 2 g) + 'card-game-command (nth 1 g) + 'action #'card-game--launch) + (insert (propertize (concat " " (nth 2 g) "\n") 'face 'shadow))) + (insert "\n"))) + (switch-to-buffer buf) + (goto-char (point-min)) + (forward-button 1))) + +;;;###autoload +(defalias 'card-games #'card-game + "Alias for `card-game'.") + +(defconst card-games-themes + '((classic :felt "#15692f" :theme t) + (dark :felt "#23272e" :back "#3b4252" :highlight "#88c0d0" :theme nil) + (contrast :felt "#0a0a0a" :back "#000000" :highlight "#ffd400" :theme nil)) + "Named table/card colour presets for `card-games-set-theme'.") + +;;;###autoload +(defun card-games-set-theme (name) + "Apply the card-games colour preset NAME (see `card-games-themes')." + (interactive + (list (intern (completing-read + "Card-games theme: " + (mapcar (lambda (e) (symbol-name (car e))) card-games-themes) + nil t)))) + (let ((p (alist-get name card-games-themes))) + (unless p (user-error "No such card-games theme: %s" name)) + (setq cg-bid-felt-color (plist-get p :felt)) + (when (plist-member p :theme) + (setq cg-svg-theme-colors (plist-get p :theme))) + (when (plist-get p :back) (setq cg-svg-back-color (plist-get p :back))) + (when (plist-get p :highlight) + (setq cg-svg-highlight-color (plist-get p :highlight))) + (message "card-games theme: %s" name))) + +(provide 'card-games) +;;; card-games.el ends here diff --git a/cg-bid-ui.el b/cg-bid-ui.el new file mode 100644 index 0000000..240c059 --- /dev/null +++ b/cg-bid-ui.el @@ -0,0 +1,1082 @@ +;;; cg-bid-ui.el --- 500 (Bid) — console UI and commands -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The console (UNICODE) interface and interactive commands for 500. +;; The rules engine lives in cg-bid.el. Play with `M-x cg-bid'. + +;;; Code: + +(require 'cl-lib) +(require 'cg-core) +(require 'cg-bid) +(require 'cg-svg) +(require 'svg) +(require 'color) + + +;;;; Rendering + +(defun cg-bid--trick-card-for (game seat) + "Return the card SEAT has played to the current (or last) trick, or nil." + (let ((tr (or (cg-get game :trick) (cg-get game :last-trick)))) + (cdr (assq seat tr)))) + +(cl-defmethod cg-render ((game cg-bid-game)) + "Return a propertized string depicting GAME." + (let* ((contract (cg-get game :contract)) + (trump (and contract (cg-bid-trump contract))) + (scores (cg-get game :scores)) + (tricks (cg-get game :tricks)) + (turn (cg-get game :turn)) + (phase (cg-get game :phase)) + (out (list))) + (push (format " 500 Bid Hand %d\n" (cg-get game :hand-no)) out) + (push (format " Score — You/North: %d West/East: %d\n" + (car scores) (cdr scores)) + out) + (when (eq phase 'gameover) + (push (propertize + (format " *** GAME OVER — %s WIN ***\n" + (if (= (cg-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) + 'face 'cg-cursor) + out)) + (push (format " Contract: %s\n\n" + (if contract + (format "%s (%s) by %s" + (cg-bid-label contract) (cg-bid-name contract) + (aref cg-bid-seat-names (cg-get game :contractor))) + "— (auction in progress)")) + out) + ;; opponents and partner: name, hand size (or exposed/sitting), played card + (cl-flet ((seatline + (seat indent) + (let ((sit (eql seat (cg-bid--sitter game))) + (exp (eql seat (cg-get game :exposed)))) + (format "%s%s%s %s played: %s\n" + indent + (aref cg-bid-seat-names seat) + (if (and (eq phase 'play) (= seat turn)) "*" " ") + (cond + (sit "(sitting out)") + (exp (format "[%s]" + (mapconcat #'cg-bid-card-string + (cg-bid-sort-hand + (cg-bid--hand game seat) trump) + " "))) + (t (format "[%d cards]" + (length (cg-bid--hand game seat))))) + (cg-bid-card-string (cg-bid--trick-card-for game seat)))))) + (push (seatline 2 " ") out) ; North (partner) + (push (seatline 1 " ") out) ; West + (push (seatline 3 " ") out)) ; East + (push (format "\n Tricks — You/North: %d West/East: %d\n\n" + (+ (aref tricks 0) (aref tricks 2)) + (+ (aref tricks 1) (aref tricks 3))) + out) + ;; human hand + (push " Your hand (South):\n " out) + (let* ((hand (cg-bid-sort-display (cg-bid--hand game 0) trump)) + (cursor (cg-get game :cursor)) + (marks (cg-get game :marks)) + (led (cg-get game :led)) + (legal (and (eq phase 'play) + (= turn 0) + (cg-bid-legal-cards (cg-bid--hand game 0) led trump)))) + (cg-put game :sorted-hand hand) + (if (null hand) + (push "(empty)" out) + (cl-loop for c in hand for i from 0 do + (let ((faces nil) + (str (cg-bid-card-string c))) + (when (cg-red-suit-p (car c)) (push 'cg-red-suit faces)) + (when (member c marks) (setq str (concat "^" str))) + (when (and legal (not (member c legal))) + (push 'cg-gap faces)) ; dim illegal plays + (when (= i cursor) (push 'cg-cursor faces)) + (push (propertize (format " %-4s" str) + 'face (or faces 'default) + 'cg-card i 'mouse-face 'highlight) + out)))) + (push "\n" out)) + (push (format "\n %s\n" (cg-get game :message)) out) + (push (cg-bid--key-help game) out) + (apply #'concat (nreverse out)))) + +(defun cg-bid--key-help (game) + "Return a context-sensitive key-help line for GAME." + (pcase (cg-get game :phase) + ('auction " [b]id [p]ass [n]ew hand [q]uit ? help\n") + ('kitty " [←/→] move [RET] mark/unmark [x] discard the 5 marked [q]uit\n") + ('play " [←/→] move [RET] play card [n]ew hand [q]uit ? help\n") + ('done " [n]ext hand [q]uit ? help\n") + ('gameover " [n]ew game [q]uit ? help\n") + (_ " [n]ew hand [q]uit ? help\n"))) + + +;;;; Graphical (SVG) table + +(defconst cg-bid--tw 44 "Table card width.") +(defconst cg-bid--th 62 "Table card height.") +(defconst cg-bid--canvas-w 600 "Table canvas width.") +(defconst cg-bid--canvas-h 460 "Table canvas height.") + +(defcustom cg-bid-felt-color "#15692f" + "Base felt colour for the 500 table. +Set to a theme-derived colour (see `cg-color') for a table that +matches your Emacs theme." + :type 'color :group 'cg-svg) + +(defcustom cg-bid-animate t + "When non-nil, pace AI turns so play is watchable." + :type 'boolean :group 'cg-svg) + +(defcustom cg-bid-ai-delay 0.45 + "Seconds to pause after each AI action when `cg-bid-animate' is on." + :type 'number :group 'cg-svg) + +(defcustom cg-bid-trick-pause 1.1 + "Seconds to leave a completed trick on the table before it is swept." + :type 'number :group 'cg-svg) + +(defcustom cg-bid-svg-ui nil + "When non-nil (and on a graphical display), render 500 as a single +full-buffer SVG: the table in the centre, a status/compass/bid panel on +the left, and a scrollable message log on the right." + :type 'boolean :group 'cg-svg) + +(defcustom cg-bid-svg-fill t + "When non-nil, size the full-SVG UI to fill the window and enlarge the +South hand, re-fitting on window changes. Only used when `cg-bid-svg-ui'." + :type 'boolean :group 'cg-svg) + + +(defun cg-bid--header-text (game) + "Return the header lines (scores, contract, tricks) for GAME." + (let ((scores (cg-get game :scores)) + (contract (cg-get game :contract)) + (tricks (cg-get game :tricks))) + (concat + (format " 500 Bid Hand %d\n" (cg-get game :hand-no)) + (format " Score - You/North: %d West/East: %d\n" + (car scores) (cdr scores)) + (if (eq (cg-get game :phase) 'gameover) + (format " *** GAME OVER - %s WIN ***\n" + (if (= (cg-get game :game-over) 0) "YOU/NORTH" "WEST/EAST")) + "") + (format " Contract: %s\n" + (if contract + (format "%s (%s) by %s" (cg-bid-label contract) + (cg-bid-name contract) + (aref cg-bid-seat-names (cg-get game :contractor))) + "- (auction in progress)")) + (format " Tricks - You/North: %d West/East: %d\n" + (+ (aref tricks 0) (aref tricks 2)) + (+ (aref tricks 1) (aref tricks 3)))))) + +(defun cg-bid--footer-text (game) + "Return the footer (message and key help) for GAME." + (concat (format "\n %s\n" (cg-get game :message)) + (cg-bid--key-help game))) + +(defun cg-bid--spec (card) + "Return the cg-svg card spec for a 500 CARD, or nil for none." + (cond ((null card) nil) + ((cg-bid-joker-p card) (cons nil 'joker)) + (t (cons (aref cg-bid-ranks (cdr card)) (car card))))) + +(defun cg-bid--south-layout (n) + "Return (X0 STEP Y) for laying N South-hand cards across the canvas." + (let* ((w cg-bid--tw) + (maxw (- cg-bid--canvas-w 24)) + (step (if (<= n 1) 0 (min (+ w 6) (/ (- maxw w) (1- n))))) + (total (+ w (* (max 0 (1- n)) step))) + (x0 (/ (- cg-bid--canvas-w total) 2)) + (y (- cg-bid--canvas-h cg-bid--th 8))) + (list x0 step y))) + +(defun cg-bid--draw-backs (svg cx top n) + "Draw a small fan of up to N face-down cards centred at CX, TOP on SVG. +Card size and fan step follow the dynamic `cg-svg-card-width'." + (let* ((cw cg-svg-card-width) + (k (min (max n 0) 6)) + (step (max 12 (round (* cw 0.42)))) + (total (if (> k 0) (+ cw (* (1- k) step)) 0)) + (x0 (- cx (/ total 2)))) + (dotimes (i k) (cg-svg-card svg (+ x0 (* i step)) top :down t)))) + +(defun cg-bid--draw-opponent (svg game seat cx top &optional fs) + "Draw opponent SEAT (label, backs, turn marker) on SVG centred at CX, TOP. +FS scales the name pill and its fonts." + (let* ((fs (or fs 1.0)) + (n (length (cg-bid--hand game seat))) + (sitter (eql seat (cg-bid--sitter game))) + (lw (round (* 104 fs))) (lh (round (* 18 fs))) + (fsz (max 11 (round (* 13 fs))))) + (svg-rectangle svg (- cx (/ lw 2)) (- top lh 3) lw lh :rx (round (* 9 fs)) + :fill "#0b3d1d" :fill-opacity 0.55) + (svg-text svg (format "%s%s" (aref cg-bid-seat-names seat) + (if sitter " (sitting out)" (format " (%d)" n))) + :x cx :y (- top (round (* 8 fs))) :font-size fsz :fill "#eaffea" + :text-anchor "middle" :font-family "sans-serif") + (when (and (eq (cg-get game :phase) 'play) (= seat (cg-get game :turn))) + (svg-text svg "*" :x cx :y (- top (round (* 22 fs))) + :font-size (round (* 18 fs)) :fill "#f1c40f" + :text-anchor "middle" :font-family "sans-serif")) + (unless sitter (cg-bid--draw-backs svg cx top n)))) + +(defun cg-bid--draw-trick (svg game) + "Draw the cards played to the current trick around the centre of SVG." + (let* ((W cg-bid--canvas-w) (H cg-bid--canvas-h) + (w cg-bid--tw) (h cg-bid--th) + (cx (/ W 2)) (cy (/ H 2)) + (spots (list (list 0 (- cx (/ w 2)) (+ cy 22)) + (list 1 (- cx 70 w) (- cy (/ h 2))) + (list 2 (- cx (/ w 2)) (- cy 22 h)) + (list 3 (+ cx 70) (- cy (/ h 2)))))) + (dolist (s spots) + (let* ((card (cg-bid--trick-card-for game (nth 0 s))) + (spec (cg-bid--spec card))) + (when spec + (cg-svg-card svg (nth 1 s) (nth 2 s) + :rank (car spec) :suit (cdr spec))))))) + +(defun cg-bid--draw-south (svg game) + "Draw South's hand face-up along the bottom of SVG; record sort order." + (let* ((trump (and (cg-get game :contract) + (cg-bid-trump (cg-get game :contract)))) + (hand (cg-bid-sort-display (cg-bid--hand game 0) trump))) + (cg-put game :sorted-hand hand) + (let* ((n (length hand)) (lay (cg-bid--south-layout n)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) + (cursor (cg-get game :cursor)) (marks (cg-get game :marks)) (i 0)) + (svg-text svg "Your hand (South)" :x (/ cg-bid--canvas-w 2) + :y (+ y cg-bid--th 14) + :font-size 12 :fill "#cfeccf" :text-anchor "middle" + :font-family "sans-serif") + (dolist (card hand) + (let* ((spec (cg-bid--spec card)) + (marked (and (member card marks) t)) + (hl (or (and (eq (cg-get game :phase) 'play) (= i cursor)) + marked)) + ;; selected cards pop up out of the hand + (cy (if marked (- y (round (* cg-bid--th 0.17))) y))) + (cg-svg-card svg (+ x0 (* i step)) cy + :rank (car spec) :suit (cdr spec) :highlight hl)) + (setq i (1+ i)))))) + +(defun cg-bid--table-svg (game) + "Return an svg object depicting the whole 500 table for GAME." + (let* ((W cg-bid--canvas-w) (H cg-bid--canvas-h) + (svg (svg-create W H))) + (let* ((base (or cg-bid-felt-color "#15692f")) + (lite (or (ignore-errors (color-lighten-name base 12)) base)) + (dark (or (ignore-errors (color-darken-name base 16)) base))) + (svg-gradient svg "cg-felt" 'radial (list (cons 0 lite) (cons 100 dark))) + (svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-felt") + (svg-ellipse svg (/ W 2) (/ H 2) 132 88 :fill "black" :fill-opacity 0.10)) + (let ((cg-svg-card-width cg-bid--tw) + (cg-svg-card-height cg-bid--th) + (cg-svg-card-gap 4)) + (cg-bid--draw-opponent svg game 2 (/ W 2) 34) + (cg-bid--draw-opponent svg game 1 80 (/ H 2)) + (cg-bid--draw-opponent svg game 3 (- W 80) (/ H 2)) + (cg-bid--draw-trick svg game) + (cg-bid--draw-south svg game)) + svg)) + +(defun cg-bid--insert-graphical (game) + "Insert the GUI (SVG) depiction of GAME into the current buffer. +Folds the controls into the single action-button row (see +`cg-bid--insert-buttons'); only the status line precedes it." + (insert (cg-bid--header-text game)) + (insert-image (cg-svg-image (cg-bid--table-svg game) (cg-scale))) + (insert (format "\n %s\n" (cg-get game :message)))) + +(defun cg-bid--south-hit (px py n) + "Map a click at PX, PY to a South-hand index (0..N-1), or nil." + (let* ((lay (cg-bid--south-layout n)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay))) + (when (and (> n 0) (>= py (- y (round (* cg-bid--th 0.17)) 4)) + (<= py (+ y cg-bid--th 8)) (>= px x0)) + (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) + (when (< i n) i))))) + + + +;;;; Interaction + +(defvar-local cg-bid--game nil "The `cg-bid-game' in the current buffer.") + +(defun cg-bid--mode-line (game) + "Return a mode-line status string for GAME." + (pcase (cg-get game :phase) + ('auction (if (= (cg-get game :bidder) 0) " [Your bid]" + (format " [%s bidding]" (aref cg-bid-seat-names (cg-get game :bidder))))) + ('kitty (if (cg-bid--human-p (cg-get game :contractor)) " [Discard 5]" + (format " [%s: kitty]" + (aref cg-bid-seat-names (cg-get game :contractor))))) + ('play (if (= (cg-get game :turn) 0) " [Your turn]" + (format " [%s to play]" (aref cg-bid-seat-names (cg-get game :turn))))) + ('done " [Hand over — n]") + ('gameover " [Game over — n]") + (_ ""))) + +(defun cg-bid--announce (game) + "Echo a prompt or status describing what to do now in GAME." + (message "%s" + (pcase (cg-get game :phase) + ('auction (if (= (cg-get game :bidder) 0) + "Your turn to bid — press b to bid (e.g. 7H) or p to pass." + (format "Waiting for %s to bid..." + (aref cg-bid-seat-names (cg-get game :bidder))))) + ('kitty (if (cg-bid--human-p (cg-get game :contractor)) + "You won the bid — mark five cards (RET) then press x to discard." + (format "%s is exchanging the kitty..." + (aref cg-bid-seat-names (cg-get game :contractor))))) + ('play (if (= (cg-get game :turn) 0) + "Your turn — pick a card (arrows + RET, or click a card)." + (format "Waiting for %s to play..." + (aref cg-bid-seat-names (cg-get game :turn))))) + ('done (or (cg-get game :hand-result) (cg-get game :message))) + (_ (cg-get game :message))))) + +(defun cg-bid--button (label cmd help) + "Insert a clickable button LABEL running CMD with tooltip HELP." + (insert-text-button label 'action (lambda (_) (call-interactively cmd)) + 'help-echo help 'follow-link t 'face 'link) + (insert " ")) + +(defun cg-bid--insert-buttons (game) + "Insert clickable buttons for the actions available now in GAME." + (insert " ") + (pcase (cg-get game :phase) + ('auction (when (= (cg-get game :bidder) 0) + (cg-bid--button "[Bid]" #'cg-bid-make-bid "Make a bid") + (cg-bid--button "[Pass]" #'cg-bid-pass "Pass"))) + ('kitty (when (cg-bid--human-p (cg-get game :contractor)) + (cg-bid--button "[Discard 5]" #'cg-bid-discard-marked + "Discard the five marked cards"))) + ('play (when (= (cg-get game :turn) 0) + (cg-bid--button "[Play]" #'cg-bid-select + "Play the highlighted card")))) + (when (memq (cg-get game :phase) '(done gameover)) + (cg-bid--button (if (eq (cg-get game :phase) 'gameover) "[New game]" "[Next hand]") + #'cg-bid-new "Deal the next hand / start a new game")) + (cg-bid--button "[Help]" #'cg-bid-help "Show help") + (insert "\n")) + +(defun cg-bid--redisplay () + "Redraw the current 500 buffer (SVG table on a graphical display)." + (let ((inhibit-read-only t) (game cg-bid--game)) + (setq-local mode-line-process (cg-bid--mode-line game)) + (erase-buffer) + (if (and cg-bid-svg-ui (display-graphic-p)) + (cg-bid--insert-svg-ui game) + (if (display-graphic-p) + (cg-bid--insert-graphical game) + (insert (cg-render game))) + (cg-bid--insert-buttons game)) + (goto-char (point-min)))) + +(defun cg-bid--refresh () + "Advance AI to the next human action, animating turns if enabled." + (let ((game cg-bid--game)) + (if (or (not cg-bid-animate) (<= cg-bid-ai-delay 0)) + (progn (cg-bid--run game) (cg-bid--redisplay)) + (cg-bid--redisplay) + (let ((guard 0)) + (while (and (< (cl-incf guard) 400) + (let ((before (cg-get game :ntricks))) + (when (cg-bid--ai-step game) + (cg-bid--redisplay) + (message "%s" (cg-get game :message)) + (sit-for (if (> (cg-get game :ntricks) before) + cg-bid-trick-pause + cg-bid-ai-delay)) + t))))) + (cg-bid--redisplay)) + (cg-bid--announce game))) + +(defun cg-bid-left () + "Move the hand cursor left." + (interactive) + (cg-put cg-bid--game :cursor (max 0 (1- (cg-get cg-bid--game :cursor)))) + (cg-bid--redisplay)) + +(defun cg-bid-right () + "Move the hand cursor right." + (interactive) + (let ((n (length (cg-get cg-bid--game :sorted-hand)))) + (cg-put cg-bid--game :cursor (min (1- n) (1+ (cg-get cg-bid--game :cursor)))) + (cg-bid--redisplay))) + +(defun cg-bid--current-card () + "Return the card under the hand cursor." + (nth (cg-get cg-bid--game :cursor) (cg-get cg-bid--game :sorted-hand))) + +(defun cg-bid-select () + "Play (in play phase) or mark/unmark (in kitty phase) the current card." + (interactive) + (let* ((game cg-bid--game) + (phase (cg-get game :phase)) + (card (cg-bid--current-card))) + (pcase phase + ('kitty + (when (cg-bid--human-p (cg-get game :contractor)) + (let ((marks (cg-get game :marks))) + (cg-put game :marks (if (member card marks) + (remove card marks) + (cons card marks))) + (cg-put game :message + (format "%d of 5 marked for discard." + (length (cg-get game :marks)))) + (cg-bid--redisplay)))) + ('play + (if (/= (cg-get game :turn) 0) + (progn (cg-put game :message "Not your turn.") (cg-bid--redisplay)) + (let ((legal (cg-bid-legal-cards (cg-bid--hand game 0) + (cg-get game :led) + (cg-bid-trump (cg-get game :contract))))) + (if (not (member card legal)) + (progn (cg-put game :message "Illegal — you must follow suit.") + (cg-bid--redisplay)) + (cg-bid--play game 0 card) + (cg-bid--refresh))))) + (_ (cg-bid--redisplay))))) + +(defun cg-bid-discard-marked () + "Discard the five marked kitty cards." + (interactive) + (let* ((game cg-bid--game) + (marks (cg-get game :marks))) + (cond + ((not (eq (cg-get game :phase) 'kitty)) + (cg-put game :message "Nothing to discard now.") (cg-bid--redisplay)) + ((/= (length marks) 5) + (cg-put game :message (format "Mark exactly 5 (have %d)." (length marks))) + (cg-bid--redisplay)) + (t (cg-bid--discard game (cg-get game :contractor) marks) + (cg-put game :marks nil) + (cg-bid--refresh))))) + +(defun cg-bid--code (bid) + "Return a short ASCII code for BID, e.g. \"7H\", \"8NT\", \"NL\"." + (let ((trump (cg-bid-trump bid)) (tricks (cg-bid-tricks bid))) + (cond ((cg-bid-nullo-p bid) (cg-bid-label bid)) + ((eq trump 'nt) (format "%dNT" tricks)) + (t (format "%d%c" tricks (aref "SCDH" trump)))))) + +(defun cg-bid-make-bid () + "Prompt the human for a bid. +Type a short code such as 7H, 8NT, NL (case-insensitive)." + (interactive) + (let* ((game cg-bid--game)) + (if (or (not (eq (cg-get game :phase) 'auction)) + (/= (cg-get game :bidder) 0)) + (progn (cg-put game :message "Not your turn to bid.") + (cg-bid--redisplay)) + (let* ((legal (cg-bid--legal-bids game)) + (completion-ignore-case t) + (choices (append (mapcar (lambda (b) + (cons (format "%-4s %s (%d)" + (cg-bid--code b) + (cg-bid-name b) + (cg-bid-value b)) + b)) + legal) + '(("Pass" . pass)))) + (pick (completing-read "Your bid (e.g. 7H, 8NT, NL; or Pass): " + (mapcar #'car choices) nil t)) + (sel (cdr (assoc pick choices)))) + (cg-bid--auction-act game 0 (if (eq sel 'pass) nil sel)) + (cg-bid--refresh))))) + +(defun cg-bid-pass () + "Pass during the auction." + (interactive) + (let ((game cg-bid--game)) + (if (or (not (eq (cg-get game :phase) 'auction)) + (/= (cg-get game :bidder) 0)) + (progn (cg-put game :message "Not your turn to bid.") + (cg-bid--redisplay)) + (cg-bid--auction-act game 0 nil) + (cg-bid--refresh)))) + +(defun cg-bid-new () + "Advance to the next hand once a hand is over, or start a fresh game at +game over. 500 is a multi-hand game with no mid-hand redeal, so a hand in +progress must be played out (unlike the solitaire games)." + (interactive) + (let* ((game cg-bid--game) (phase (cg-get game :phase))) + (cond + ((eq phase 'gameover) + (cg-put game :scores (cons 0 0)) + (cg-put game :hand-no 0) + (cg-put game :game-over nil) + (cg-bid--deal game 3) + (cg-bid--refresh)) + ((eq phase 'done) + (cg-bid--deal game (mod (1+ (cg-get game :dealer)) 4)) + (cg-bid--refresh)) + (t (cg-put game :message "Play the hand out — 500 has no mid-hand redeal.") + (cg-bid--redisplay))))) + +(defun cg-bid-mouse (event) + "Handle a click in the 500 buffer (SVG-UI panels, table, or text)." + (interactive "e") + (let ((start (event-start event)) (game cg-bid--game)) + (if (and cg-bid-svg-ui (display-graphic-p) (posn-image start)) + (cg-bid--svg-ui-click start) + (let ((i (if (and (display-graphic-p) (posn-image start)) + (let ((xy (posn-object-x-y start)) (s (cg-scale))) + (and xy (cg-bid--south-hit (round (/ (car xy) s)) + (round (/ (cdr xy) s)) + (length (cg-get game :sorted-hand))))) + (let ((pos (posn-point start))) + (and pos (get-text-property pos 'cg-card)))))) + (when i (cg-put game :cursor i) (cg-bid-select)))))) + +(defun cg-bid-help () + "Show brief help." + (interactive) + (message "%s" (concat "500: win the auction, exchange the kitty, take your bid " + "in tricks. Trump order: Joker, right bower, left bower, " + "A K Q 10 9 8 7 6 5 4. b=bid p=pass, arrows+RET to play."))) + +(defun cg-bid-zoom-in () + "Enlarge the cards." (interactive) (text-scale-increase 1) (cg-bid--redisplay)) +(defun cg-bid-zoom-out () + "Shrink the cards." (interactive) (text-scale-decrease 1) (cg-bid--redisplay)) +(defun cg-bid-zoom-reset () + "Reset the card size." (interactive) (text-scale-set 0) (cg-bid--redisplay)) + +(defun cg-bid-redraw () + "Redraw the table (e.g. after a theme or frame change)." + (interactive) + (cg-bid--redisplay)) + +(defvar cg-bid-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-bid-left) + (define-key map (kbd "") #'cg-bid-right) + (define-key map (kbd "RET") #'cg-bid-select) + (define-key map "b" #'cg-bid-make-bid) + (define-key map "p" #'cg-bid-pass) + (define-key map "x" #'cg-bid-discard-marked) + (define-key map "g" #'cg-bid-redraw) + (define-key map "n" #'cg-bid-new) + (define-key map "?" #'cg-bid-help) + (define-key map "+" #'cg-bid-zoom-in) + (define-key map "=" #'cg-bid-zoom-in) + (define-key map "-" #'cg-bid-zoom-out) + (define-key map "0" #'cg-bid-zoom-reset) + (define-key map (kbd "M-") #'cg-bid-log-up) + (define-key map (kbd "M-") #'cg-bid-log-down) + (define-key map [wheel-up] #'cg-bid-wheel) + (define-key map [wheel-down] #'cg-bid-wheel) + (define-key map [mouse-4] #'cg-bid-wheel) + (define-key map [mouse-5] #'cg-bid-wheel) + (define-key map "v" #'cg-bid-toggle-svg-ui) + (define-key map [mouse-1] #'cg-bid-mouse) + map) + "Keymap for `cg-bid-mode' (Emacs style; see `cg-keys').") + +(defun cg-bid--classic-keymap () + "Return a copy of `cg-bid-mode-map' with vi-style h/l and SPC added." + (let ((map (copy-keymap cg-bid-mode-map))) + (define-key map "h" #'cg-bid-left) + (define-key map "l" #'cg-bid-right) + (define-key map (kbd "SPC") #'cg-bid-select) + map)) + +(define-derived-mode cg-bid-mode special-mode "500" + "Major mode for playing 500 (Bid)." + (setq-local truncate-lines t) + (add-hook 'window-configuration-change-hook #'cg-bid--fit nil t) + (when (eq cg-keys 'classic) + (use-local-map (cg-bid--classic-keymap)))) + +;;;###autoload +(defun cg-bid () + "Play 500 (Bid) against three computer opponents." + (interactive) + (let ((buf (get-buffer-create "*500 Bid*"))) + (with-current-buffer buf + (cg-bid-mode) + (setq cg-bid--game (cg-bid--deal (make-instance 'cg-bid-game))) + (cg-bid--refresh)) + (switch-to-buffer buf))) + + +;;;; Frameless full-SVG UI (opt-in; see `cg-bid-svg-ui') + +(defconst cg-bid--ui-w 860 "Default SVG-UI canvas width.") +(defconst cg-bid--ui-h 540 "Default SVG-UI canvas height.") +(defconst cg-bid--ui-tx 210 "Left edge of the table area.") +(defconst cg-bid--ui-tw 440 "Default width of the table area.") +(defconst cg-bid--sw 58 "South-hand card width (larger, for readability).") +(defconst cg-bid--sh 82 "South-hand card height.") + +(defconst cg-bid--south-minfrac 0.30 + "Minimum South-card step as a fraction of card width. +The smallest gutter that still keeps each card's rank/suit index visible.") + +(defun cg-bid--south-size (w h) + "Return (SW . SH) South-card size for a canvas W by H. +The player's cards grow with the window; height grows about twice as +fast as the window widens, so the hand compresses (cards overlap) as the +table enlarges. Capped at 42% of canvas height; width is capped later, +per-deal, so the hand always fits the table." + (let* ((wf (- w cg-bid--ui-w)) (hf (- h cg-bid--ui-h)) + (sh (max 76 (min (round (* h 0.42)) + (round (+ 92 (* hf 0.20) (* wf 0.40)))))) + (sw (round (* sh 0.70)))) + (cons sw sh))) + +(defvar-local cg-bid--regions nil + "Plist of clickable SVG-UI regions for hit-testing.") +(defvar-local cg-bid--last-size nil + "Last window pixel size used to render the SVG-UI.") + +(defun cg-bid--in-rect (px py rect) + "Return non-nil when PX,PY lie inside RECT (X Y W H)." + (and rect (>= px (nth 0 rect)) (< px (+ (nth 0 rect) (nth 2 rect))) + (>= py (nth 1 rect)) (< py (+ (nth 1 rect) (nth 3 rect))))) + +(defun cg-bid--text-left (svg str x y size color &optional bold) + "Draw left-anchored text STR on SVG." + (let ((a (list :x (round x) :y (round y) :font-size (round size) + :fill color :text-anchor "start" :font-family cg-svg-font-family))) + (when bold (setq a (append a (list :font-weight "bold")))) + (apply #'svg-text svg str a))) + +(defun cg-bid--ui-label (svg str x y &optional size) + "Draw an all-caps, letter-spaced section label on SVG (font SIZE, default 10)." + (svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round (or size 10)) + :fill "#8fc79b" :text-anchor "start" :font-family cg-svg-font-family + :font-weight "bold" :letter-spacing "2")) + +(defun cg-bid--ui-divider (svg x1 x2 y) + "Draw a faint horizontal divider on SVG." + (svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1)) + +(defun cg-bid--active-seat (game) + "Return the seat whose action is pending, or nil." + (pcase (cg-get game :phase) + ('auction (cg-get game :bidder)) + ('kitty (cg-get game :contractor)) + ('play (cg-get game :turn)) + (_ nil))) + +(defun cg-bid--hand-layout (n width xoff ybottom &optional cardw cardh) + "Return (X0 STEP Y) for N cards across WIDTH from XOFF, bottom YBOTTOM. +CARDW/CARDH default to the table card size. Cards overlap to fit but +keep a minimum gutter so each rank index stays visible." + (let* ((w (or cardw cg-bid--tw)) + (hgt (or cardh cg-bid--th)) + (maxw (- width 24)) + (minstep (max 14 (round (* w cg-bid--south-minfrac)))) + (fit (if (<= n 1) 0 (/ (- maxw w) (1- n)))) + (step (if (<= n 1) 0 (max minstep (min (+ w 7) fit)))) + (total (+ w (* (max 0 (1- n)) step))) + (x0 (+ xoff (/ (- width total) 2))) + (y (- ybottom hgt 8))) + (list x0 step y))) + +(defun cg-bid--draw-trick-at (svg game cx cy &optional fs) + "Draw the current trick centred at CX, CY on SVG, on a faint drop-zone. +FS scales the drop-zone, the played cards, and their spread." + (let* ((fs (or fs 1.0)) + (r (round (* 80 fs))) + (w (round (* cg-bid--tw fs))) (h (round (* cg-bid--th fs))) + (off (round (* 70 fs))) (gap (round (* 22 fs))) + (spots (list (list 0 (- cx (/ w 2)) (+ cy gap)) + (list 1 (- cx off w) (- cy (/ h 2))) + (list 2 (- cx (/ w 2)) (- cy gap h)) + (list 3 (+ cx off) (- cy (/ h 2)))))) + (svg-circle svg cx cy r :fill "#000000" :fill-opacity 0.08) + (svg-circle svg cx cy r :fill "none" :stroke "#0e5226" :stroke-width 2) + (let ((cg-svg-card-width w) (cg-svg-card-height h)) + (dolist (s spots) + (let* ((card (cg-bid--trick-card-for game (nth 0 s))) (spec (cg-bid--spec card))) + (when spec + (cg-svg-card svg (nth 1 s) (nth 2 s) :rank (car spec) :suit (cdr spec)))))))) + +(defun cg-bid--draw-south-region (svg game tx tw ybottom sw sh) + "Draw South's hand (cards SW by SH) within TX width TW bottom YBOTTOM. +Return (:hand (X0 STEP Y N SH))." + (let* ((trump (and (cg-get game :contract) (cg-bid-trump (cg-get game :contract)))) + (hand (cg-bid-sort-display (cg-bid--hand game 0) trump))) + (cg-put game :sorted-hand hand) + (let* ((n (length hand)) + ;; Cap card width so N cards fit the table at the index-safe + ;; gutter; tall cards shrink only when the table is too narrow. + (maxsw (if (<= n 1) sw + (/ (- tw 24.0) (+ 1.0 (* (1- n) cg-bid--south-minfrac))))) + (capped (and (> n 1) (> sw maxsw))) + (sw (if capped (max 40 (round maxsw)) sw)) + (sh (if capped (round (/ sw 0.70)) sh)) + (lay (cg-bid--hand-layout n tw tx ybottom sw sh)) + (x0 (nth 0 lay)) (step (nth 1 lay)) (y (nth 2 lay)) + (cursor (cg-get game :cursor)) (marks (cg-get game :marks)) (i 0)) + (svg-rectangle svg tx (- y 6) tw (+ sh 14) :rx 10 + :fill "#ffffff" :fill-opacity 0.05) + (let ((cg-svg-card-width sw) (cg-svg-card-height sh)) + (dolist (card hand) + (let* ((spec (cg-bid--spec card)) (marked (and (member card marks) t)) + (hl (or (and (eq (cg-get game :phase) 'play) (= i cursor)) marked)) + (cy (if marked (- y (round (* sh 0.17))) y))) + (cg-svg-card svg (+ x0 (* i step)) cy + :rank (car spec) :suit (cdr spec) :highlight hl)) + (setq i (1+ i)))) + (list :hand (list x0 step y n sh))))) + +(defun cg-bid--draw-compass (svg game cx cy r &optional fs) + "Draw a compass turn indicator centred at CX, CY radius R on SVG. +FS scales the N/S/E/W label fonts." + (let ((active (cg-bid--active-seat game)) + (lsz (max 12 (round (* 13 (or fs 1.0)))))) + (svg-circle svg cx cy r :fill "#0d4a22" :stroke "#0a3a1a" :stroke-width 2) + (svg-circle svg cx cy (- r 7) :fill "none" :stroke "#1b6b35" :stroke-width 1) + (cl-flet ((lab (seat lx ly s) + (cg-svg--text svg s lx ly lsz + (if (eql seat active) "#f6e27a" "#bfe0bf") + (eql seat active)))) + (lab 2 cx (- cy r -15) "N") + (lab 0 cx (+ cy r -5) "S") + (lab 1 (- cx r -11) (+ cy 5) "W") + (lab 3 (+ cx r -11) (+ cy 5) "E")) + (when active + (let* ((tip (pcase active + (2 (cons cx (- cy (- r 16)))) + (0 (cons cx (+ cy (- r 16)))) + (1 (cons (- cx (- r 16)) cy)) + (3 (cons (+ cx (- r 16)) cy))))) + (svg-line svg cx cy (car tip) (cdr tip) :stroke "#f1c40f" :stroke-width 2) + (svg-circle svg (car tip) (cdr tip) 3 :fill "#f1c40f"))) + (svg-circle svg cx cy 3 :fill "#cfeccf"))) + +(defun cg-bid--draw-logo (svg cx cy &optional fs) + "Draw a GNU Emacs emblem centred at CX, CY on SVG, scaled by FS." + (let ((fs (or fs 1.0))) + (svg-gradient svg "cg-logo" 'linear '((0 . "#8056c8") (100 . "#3f1f9e"))) + (svg-circle svg cx cy (round (* 26 fs)) :gradient "cg-logo" + :stroke "#2a1370" :stroke-width 2) + (cg-svg--text svg "e" cx (+ cy (round (* 10 fs))) (round (* 30 fs)) "#ffffff" t) + (cg-svg--text svg "GNU Emacs" cx (+ cy (round (* 42 fs))) + (max 10 (round (* 11 fs))) "#c7bbe6"))) + +(defun cg-bid--grid-cell (bid gx gy cw ch g) + "Return (X Y W H) for BID in a grid at GX,GY with cells CW by CH, gutter G. +Suit/NT bids occupy rows by trick count (6-10) and columns by suit; +nullo bids share the bottom row." + (if (cg-bid-nullo-p bid) + (let ((col (pcase (cg-bid-label bid) ("ON" 1) ("GN" 2) (_ 0)))) + (list (+ gx (* col (+ cw g))) (+ gy (* 5 (+ ch g))) cw ch)) + (let ((col (if (eq (cg-bid-trump bid) 'nt) 4 (cg-bid-trump bid))) + (row (- (cg-bid-tricks bid) 6))) + (list (+ gx (* col (+ cw g))) (+ gy (* row (+ ch g))) cw ch)))) + +(defun cg-bid--grid-pass-cell (gx gy cw ch g) + "Return (X Y W H) for the double-width Pass button (bottom row, cols 3-4)." + (list (+ gx (* 3 (+ cw g))) (+ gy (* 5 (+ ch g))) (+ (* 2 cw) g) ch)) + +(defun cg-bid--draw-left-panel (svg game h lpw fs ccy) + "Draw the full-height left status panel; return its clickable regions. +LPW is the panel width, FS the font/element scale, CCY the compass centre +Y (also the North reference line). All metrics scale with FS so the +panel content grows with the window." + (let* ((scores (cg-get game :scores)) + (contract (cg-get game :contract)) + (regions nil) + (F (lambda (n) (round (* n fs)))) + (px0 (funcall F 16)) (pxr (- lpw (funcall F 12))) + (dl (funcall F 8)) (dr (- lpw (funcall F 8))) + (cxp (/ lpw 2)) + (cr (funcall F 44)) + (y 0)) + (svg-rectangle svg 6 6 (- lpw 8) (- h 12) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 + :stroke "#0a3a1a" :stroke-width 1) + (cg-bid--draw-compass svg game cxp ccy cr fs) + (setq y (+ ccy cr (funcall F 12))) + (cg-bid--ui-divider svg dl dr y) + (setq y (+ y (funcall F 18))) + (cg-bid--ui-label svg "Scores" px0 y (funcall F 10)) + (setq y (+ y (funcall F 22))) + (cg-bid--text-left svg "You / North" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (car scores)) :x pxr :y y + :font-size (funcall F 14) :fill "#eaffea" :text-anchor "end" + :font-family cg-svg-font-family :font-weight "bold") + (setq y (+ y (funcall F 20))) + (cg-bid--text-left svg "West / East" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (cdr scores)) :x pxr :y y + :font-size (funcall F 14) :fill "#eaffea" :text-anchor "end" + :font-family cg-svg-font-family :font-weight "bold") + (setq y (+ y (funcall F 16))) + (cg-bid--ui-divider svg dl dr y) + (setq y (+ y (funcall F 18))) + (cg-bid--ui-label svg "Contract" px0 y (funcall F 10)) + (setq y (+ y (funcall F 32))) + (cg-svg--text svg (if contract (cg-bid-label contract) "Auction…") + cxp y (funcall F 24) "#f1c40f" t) + (setq y (+ y (funcall F 20))) + (if contract + (let ((tr (cg-get game :tricks))) + (cg-bid--text-left svg + (format "%s — tricks %d:%d" + (aref cg-bid-seat-names (cg-get game :contractor)) + (+ (aref tr 0) (aref tr 2)) (+ (aref tr 1) (aref tr 3))) + px0 y (funcall F 12) "#cfeccf")) + (cg-bid--text-left svg "Bidding in progress" px0 y (funcall F 12) "#9fd0a8")) + (setq y (+ y (funcall F 14))) + (cg-bid--ui-divider svg dl dr y) + (when (and (eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0)) + (setq y (+ y (funcall F 18))) + (cg-bid--ui-label svg "Your bid" px0 y (funcall F 10)) + ;; extra breathing room between the label and the grid + (setq y (+ y (funcall F 16))) + (let* ((gx px0) (gy y) + (g (funcall F 5)) + (cw (max 24 (/ (- lpw px0 (funcall F 12) (* 4 g)) 5))) + (ch (funcall F 26)) + (legal (cg-bid--legal-bids game)) (bids nil)) + (dolist (b cg-bid-schedule) + (when (memq b legal) + (let* ((cell (cg-bid--grid-cell b gx gy cw ch g)) + (x (nth 0 cell)) (cy2 (nth 1 cell)) (w (nth 2 cell)) (h2 (nth 3 cell)) + (color (cg-svg--suit-color (pcase (cg-bid-trump b) + ('nt 0) ('nullo 'joker) (n n))))) + (svg-rectangle svg x cy2 w h2 :rx 5 :fill "#fdfdfb" + :stroke color :stroke-width 1) + (cg-svg--text svg (cg-bid-label b) (+ x (/ w 2)) (+ cy2 (round (* h2 0.66))) + (funcall F 12) color t) + (push (cons b cell) bids)))) + (setq regions (plist-put regions :bids bids)) + (let ((pr (cg-bid--grid-pass-cell gx gy cw ch g))) + (svg-rectangle svg (nth 0 pr) (nth 1 pr) (nth 2 pr) (nth 3 pr) + :rx 5 :fill "#7f8c8d" :stroke "#566573" :stroke-width 1) + (cg-svg--text svg "Pass" (+ (nth 0 pr) (/ (nth 2 pr) 2)) + (+ (nth 1 pr) (round (* ch 0.66))) + (funcall F 12) "#ffffff" t) + (setq regions (plist-put regions :pass pr))))) + regions)) + +(defun cg-bid--draw-log (svg game x w h fs ccy) + "Draw the full-height right log panel (emblem + scrolling story); return regions. +FS scales the emblem and fonts; CCY aligns the divider with the compass." + (let* ((F (lambda (n) (round (* n fs)))) + (y 6) (bottom (- h 6)) + (logtop (+ ccy (funcall F 44) (funcall F 12))) ; align with left divider + (lh (funcall F 16)) + (list-top (+ logtop (funcall F 24))) + (tw (funcall F 5)) (tx (+ x w (- (funcall F 10)))) + (log (cg-get game :log)) (total (max 1 (length log))) + (scroll (or (cg-get game :log-scroll) 0)) + (vis (max 1 (/ (- bottom list-top) lh))) + (maxch (max 12 (round (/ (- w (funcall F 22)) (* 0.62 (funcall F 11))))))) + (svg-rectangle svg x y w (- bottom y) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 + :stroke "#0a3a1a" :stroke-width 1) + ;; emblem in the open top area, divider aligned with the left compass divider + (cg-bid--draw-logo svg (+ x (/ w 2)) ccy fs) + (cg-bid--ui-divider svg (+ x (funcall F 10)) (- (+ x w) (funcall F 10)) logtop) + (cg-bid--ui-label svg "Log" (+ x (funcall F 12)) (+ logtop (funcall F 16)) (funcall F 10)) + ;; scrollbar track + proportional thumb + delicate arrows + (svg-rectangle svg tx list-top tw (- bottom list-top) :rx 2 :fill "#0a3a1a") + (let* ((th2 (max 16 (round (* (- bottom list-top) (min 1.0 (/ (float vis) total)))))) + (room (- (- bottom list-top) th2)) + (ty2 (+ list-top (round (* room (/ (float scroll) (max 1 (- total 1))))))) + (up (list tx (- list-top 11) tw 9)) (dn (list tx (+ bottom 2) tw 9))) + (svg-rectangle svg tx ty2 tw th2 :rx 2 :fill "#7fae8a") + (svg-polygon svg (list (cons (+ tx 2) (nth 1 up)) (cons (- tx 1) (+ (nth 1 up) 7)) + (cons (+ tx 5) (+ (nth 1 up) 7))) :fill "#9fd0a8") + (svg-polygon svg (list (cons (- tx 1) (nth 1 dn)) (cons (+ tx 5) (nth 1 dn)) + (cons (+ tx 2) (+ (nth 1 dn) 7))) :fill "#9fd0a8") + ;; entries: newest first; top item gets ceremony; alternating stripes + (let ((yy (+ list-top (funcall F 12))) (ents (nthcdr scroll log)) (k 0)) + (while (and ents (< k vis)) + (let* ((sline (car ents)) (top? (= k 0))) + (when (cl-oddp k) + (svg-rectangle svg (+ x (funcall F 6)) (- yy (funcall F 12)) + (- w (funcall F 22)) lh :fill "#ffffff" :fill-opacity 0.05)) + (when (> (length sline) maxch) + (setq sline (concat (substring sline 0 (1- maxch)) "…"))) + (cg-bid--text-left svg sline (+ x (funcall F 10)) yy + (if top? (funcall F 13) (funcall F 11)) + (if top? "#f4faf4" "#cfe3cf") top?) + (setq yy (+ yy (if top? (funcall F 22) lh)))) + (setq ents (cdr ents) k (1+ k)))) + (list :scroll-up up :scroll-down dn :log-region (list x y w (- bottom y)))))) + +(defun cg-bid--ui-svg (game &optional w h) + "Return (SVG . REGIONS) for the full-buffer SVG-UI of GAME (W by H). +Everything scales proportionally with the canvas: FS drives fonts and +table cards, PSCALE the side-panel widths." + (let* ((W (or w cg-bid--ui-w)) (H (or h cg-bid--ui-h)) + (svg (svg-create W H)) (regions nil) + ;; master scales relative to the base 860x540 canvas + (fs (max 1.0 (min 2.0 (/ (+ (/ (float W) cg-bid--ui-w) + (/ (float H) cg-bid--ui-h)) 2.0)))) + (pscale (max 1.0 (min 1.7 (/ (float W) cg-bid--ui-w)))) + (lpw (round (* 196 pscale))) + (rp-w (round (* 206 pscale))) + (rp-x (- W rp-w)) + (tx (+ lpw 14)) (tw (max 320 (- rp-x tx 8))) + (ty 8) (th (- H 16)) + (cx (+ tx (/ tw 2))) (cy (+ ty (/ th 2))) + ;; opponent/trick card size grows up to ~2x + (otw (round (* cg-bid--tw fs))) (oth (round (* cg-bid--th fs))) + ;; compass-centre line; North sits just below it, its name just above + (ccy (max 56 (round (* H 0.12))))) + (let* ((base (or cg-bid-felt-color "#15692f")) + (lite (or (ignore-errors (color-lighten-name base 12)) base)) + (dark (or (ignore-errors (color-darken-name base 18)) base))) + (svg-gradient svg "cg-felt2" 'radial (list (cons 0 lite) (cons 100 dark))) + (svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-felt2") + (svg-rectangle svg (- tx 6) 8 (+ tw 12) (- H 16) :rx 12 + :fill "none" :stroke "#0e5226" :stroke-width 2)) + (let ((cg-svg-card-width otw) (cg-svg-card-height oth) + (cg-svg-card-gap (max 2 (round (* 4 fs)))) + (inset (round (* 70 fs)))) + ;; North: cards just below the compass line, name just above it + (cg-bid--draw-opponent svg game 2 cx (+ ccy (round (* 4 fs))) fs) + ;; West/East: vertically centred on the table midline + (cg-bid--draw-opponent svg game 1 (+ tx inset) (- cy (/ oth 2)) fs) + (cg-bid--draw-opponent svg game 3 (- (+ tx tw) inset) (- cy (/ oth 2)) fs) + (cg-bid--draw-trick-at svg game cx (- cy 24) fs)) + (let ((ss (cg-bid--south-size W H))) + (setq regions (append regions + (cg-bid--draw-south-region svg game tx tw (+ ty th) + (car ss) (cdr ss))))) + (let* ((hy (nth 2 (plist-get regions :hand))) + (bw (round (* 120 fs))) (bh (round (* 26 fs))) + (bx (- cx (/ bw 2))) (by (- hy bh (round (* 8 fs)))) + (active (memq (cg-get game :phase) '(done gameover)))) + (svg-rectangle svg bx by bw bh :rx 6 + :fill (if active "#2e7d32" "#14401f") + :fill-opacity (if active 1.0 0.55) + :stroke "#0a3a1a" :stroke-width 1) + (cg-svg--text svg "Next hand" (+ bx (/ bw 2)) (+ by (round (* bh 0.66))) + (round (* 14 fs)) (if active "#ffffff" "#7fa888") active) + (when active (setq regions (plist-put regions :next (list bx by bw bh))))) + (setq regions (append regions (cg-bid--draw-left-panel svg game H lpw fs ccy))) + (setq regions (append regions (cg-bid--draw-log svg game rp-x rp-w H fs ccy))) + (cons svg regions))) + +(defun cg-bid--insert-svg-ui (game) + "Insert the full-buffer SVG-UI for GAME and record its regions. +When `cg-bid-svg-fill', size the canvas to fill the window." + (let* ((win (get-buffer-window (current-buffer))) + (fill (and cg-bid-svg-fill win)) + (w (if fill (max 720 (window-body-width win t)) cg-bid--ui-w)) + (h (if fill (max 470 (- (window-body-height win t) 4)) cg-bid--ui-h)) + (sr (cg-bid--ui-svg game w h))) + (when fill (setq cg-bid--last-size (cons (window-body-width win t) + (window-body-height win t)))) + (setq cg-bid--regions (cdr sr)) + (insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale)))))) + +(defun cg-bid--fit (&rest _) + "Re-render the SVG-UI to fit the window after a configuration change." + (when (and cg-bid--game cg-bid-svg-ui cg-bid-svg-fill + (eq major-mode 'cg-bid-mode)) + (let ((win (get-buffer-window (current-buffer)))) + (when win + (let ((sz (cons (window-body-width win t) (window-body-height win t)))) + (unless (equal sz cg-bid--last-size) + (setq cg-bid--last-size sz) + (cg-bid--redisplay))))))) + +(defun cg-bid-log-up () + "Scroll the SVG-UI message log towards older entries." + (interactive) + (let* ((game cg-bid--game) (max (max 0 (1- (length (cg-get game :log)))))) + (cg-put game :log-scroll (min max (1+ (or (cg-get game :log-scroll) 0)))) + (cg-bid--redisplay))) + +(defun cg-bid-log-down () + "Scroll the SVG-UI message log towards newer entries." + (interactive) + (let ((game cg-bid--game)) + (cg-put game :log-scroll (max 0 (1- (or (cg-get game :log-scroll) 0)))) + (cg-bid--redisplay))) + +(defun cg-bid-wheel (event) + "Scroll the message log when the wheel turns over the log area. +Elsewhere, fall back to normal buffer scrolling." + (interactive "e") + (let ((start (event-start event)) (rg cg-bid--regions) (handled nil)) + (when (and cg-bid-svg-ui (display-graphic-p) (posn-image start)) + (let* ((xy (posn-object-x-y start)) (s (cg-scale)) + (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s)))) + (when (cg-bid--in-rect px py (plist-get rg :log-region)) + (setq handled t) + (pcase (event-basic-type event) + ((or 'wheel-up 'mouse-4) (cg-bid-log-up)) + ((or 'wheel-down 'mouse-5) (cg-bid-log-down)))))) + (unless handled + (ignore-errors (require 'mwheel) (mwheel-scroll event))))) + +(defun cg-bid--region-bid (px py rg) + "Return the bid whose button rect contains PX,PY in REGIONS RG, or nil." + (cl-some (lambda (e) (and (cg-bid--in-rect px py (cdr e)) (car e))) + (plist-get rg :bids))) + +(defun cg-bid--region-hand (px py hl) + "Return the South-hand index at PX,PY given hand layout HL, or nil." + (when hl + (let ((x0 (nth 0 hl)) (step (nth 1 hl)) (y (nth 2 hl)) (n (nth 3 hl)) + (sh (or (nth 4 hl) cg-bid--sh))) + (when (and (> n 0) (>= py (- y (round (* sh 0.17)) 4)) + (<= py (+ y sh 8)) (>= px x0)) + (let ((i (if (<= step 0) 0 (/ (- px x0) step)))) (when (< i n) i)))))) + +(defun cg-bid--svg-ui-click (start) + "Dispatch a click at posn START within the SVG-UI." + (let* ((xy (posn-object-x-y start)) (s (cg-scale)) + (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s))) + (game cg-bid--game) (rg cg-bid--regions) bid) + (cond + ((cg-bid--in-rect px py (plist-get rg :scroll-up)) (cg-bid-log-up)) + ((cg-bid--in-rect px py (plist-get rg :scroll-down)) (cg-bid-log-down)) + ((cg-bid--in-rect px py (plist-get rg :next)) (cg-bid-new)) + ((and (cg-bid--in-rect px py (plist-get rg :pass)) + (eq (cg-get game :phase) 'auction) (= (cg-get game :bidder) 0)) + (cg-bid--auction-act game 0 nil) (cg-bid--refresh)) + ((setq bid (cg-bid--region-bid px py rg)) + (cg-bid--auction-act game 0 bid) (cg-bid--refresh)) + (t (let ((i (cg-bid--region-hand px py (plist-get rg :hand)))) + (when i (cg-put game :cursor i) (cg-bid-select))))))) + +(defun cg-bid-toggle-svg-ui () + "Toggle the full-buffer SVG UI for 500." + (interactive) + (setq cg-bid-svg-ui (not cg-bid-svg-ui)) + (setq cg-bid--last-size nil) + (cg-bid--redisplay) + (message "Full-SVG UI %s" (if cg-bid-svg-ui "enabled" "disabled"))) + +(provide 'cg-bid-ui) +;;; cg-bid-ui.el ends here diff --git a/cg-bid.el b/cg-bid.el new file mode 100644 index 0000000..9f12ec4 --- /dev/null +++ b/cg-bid.el @@ -0,0 +1,844 @@ +;;; cg-bid.el --- 500 (Bid) — game logic -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; 500 ("Bid"): the four-handed partnership trick-taking game. This +;; file holds the rules engine (deck, auction, kitty, trick play, +;; scoring, the full game to 500, and the basic AI). The console UI and +;; the `cg-bid' command live in cg-bid-ui.el. +;; +;; You sit South (seat 0); partner North (2); West (1) and East (3) +;; oppose. A side wins only by reaching 500 on a contract it made (the +;; "front door"); a side that sinks to -500 loses ("back door"). +;; +;; Deck (Corwin's 45-card variant): Four..Ace in all four suits plus a +;; single Joker; ten cards each and a five-card kitty. With a trump +;; suit the order is Joker, right bower (jack of trumps), left bower +;; (other jack of the trump colour), then A K Q 10 9 8 7 6 5 4. In +;; no-trumps the Joker is the only trump and is highest. Misère/Nullo +;; is "own hand": the contractor's partner sits out and the contractor +;; tries to take no tricks; Open Nullo exposes the hand after trick one. + +;;; Code: + +(require 'cl-lib) +(require 'cg-core) + + +;;;; Cards specific to 500 + +(defconst cg-bid-ranks + ["4" "5" "6" "7" "8" "9" "10" "J" "Q" "K" "A"] + "Rank labels indexed 0..10 (Four through Ace). Index 7 is the Jack.") + +(defconst cg-bid-jack 7 "Rank index of the Jack.") +(defconst cg-bid-joker '(4 . 0) "Canonical Joker card; suit index 4.") + +(defsubst cg-bid-joker-p (card) + "Return non-nil when CARD is the Joker." + (and (consp card) (= (car card) 4))) + +(defun cg-bid-card-string (card) + "Return a short label for CARD." + (cond + ((null card) "--") + ((cg-bid-joker-p card) "Jk") + (t (concat (aref cg-bid-ranks (cdr card)) (aref cg-suits (car card)))))) + +(defun cg-bid--full-deck () + "Return the 45-card deck as a list of cards." + (cons (cons 4 0) + (cl-loop for s below 4 + append (cl-loop for r below 11 collect (cons s r))))) + + +;;;; The Avondale-style bid schedule + +(defconst cg-bid-schedule + ;; (LABEL NAME VALUE TRICKS TRUMP OPEN) + ;; TRUMP: 0-3 suit, nt, or nullo. + '(("6♠" "Six Spades" 40 6 0) + ("6♣" "Six Clubs" 60 6 1) + ("6♦" "Six Diamonds" 80 6 2) + ("6♥" "Six Hearts" 100 6 3) + ("6NT" "Six No Trump" 120 6 nt) + ("7♠" "Seven Spades" 140 7 0) + ("7♣" "Seven Clubs" 160 7 1) + ("7♦" "Seven Diamonds" 180 7 2) + ("7♥" "Seven Hearts" 200 7 3) + ("7NT" "Seven No Trump" 220 7 nt) + ("8♠" "Eight Spades" 240 8 0) + ("NL" "Nullo" 250 0 nullo) + ("8♣" "Eight Clubs" 260 8 1) + ("8♦" "Eight Diamonds" 280 8 2) + ("8♥" "Eight Hearts" 300 8 3) + ("8NT" "Eight No Trump" 320 8 nt) + ("9♠" "Nine Spades" 340 9 0) + ("ON" "Open Nullo" 350 0 nullo t) + ("9♣" "Nine Clubs" 360 9 1) + ("9♦" "Nine Diamonds" 380 9 2) + ("9♥" "Nine Hearts" 400 9 3) + ("9NT" "Nine No Trump" 420 9 nt) + ("10♠" "Ten Spades" 440 10 0) + ("GN" "Grand Nullo" 450 0 nullo t) + ("10♣" "Ten Clubs" 460 10 1) + ("10♦" "Ten Diamonds" 480 10 2) + ("10♥" "Ten Hearts" 500 10 3) + ("10NT" "Ten No Trump" 520 10 nt)) + "Bidding schedule, ascending by value. +Each entry is (LABEL NAME VALUE TRICKS TRUMP [OPEN]).") + +(defsubst cg-bid-label (bid) (nth 0 bid)) +(defsubst cg-bid-name (bid) (nth 1 bid)) +(defsubst cg-bid-value (bid) (nth 2 bid)) +(defsubst cg-bid-tricks (bid) (nth 3 bid)) +(defsubst cg-bid-trump (bid) (nth 4 bid)) +(defsubst cg-bid-open-p (bid) (nth 5 bid)) +(defsubst cg-bid-nullo-p (bid) (eq (cg-bid-trump bid) 'nullo)) + + +;;;; Card power and trick logic + +(defun cg-bid-effective-suit (card trump) + "Return the suit CARD belongs to for following, given TRUMP. +TRUMP is a suit index 0-3, or the symbol `nt' or `nullo'. +The left bower counts as the trump suit; the Joker counts as +trump (or as its own suit `joker' when there is no trump suit)." + (cond + ((cg-bid-joker-p card) (if (memq trump '(nt nullo)) 'joker trump)) + ((and (numberp trump) + (= (cdr card) cg-bid-jack) + (= (car card) (cg-sister-suit trump))) + trump) + (t (car card)))) + +(defun cg-bid-power (card trump led) + "Return an integer strength for CARD given TRUMP and the LED suit. +Higher wins. Cards that are neither trump nor of the led suit score +below 100 and so can never win a trick." + (let ((es (cg-bid-effective-suit card trump))) + (cond + ((cg-bid-joker-p card) 1000) + ((and (numberp trump) (eq es trump)) + (cond + ((and (= (cdr card) cg-bid-jack) (= (car card) trump)) 900) ; right bower + ((= (cdr card) cg-bid-jack) 899) ; left bower + (t (+ 800 (cdr card))))) + ((eq es led) (+ 100 (cdr card))) + (t (cdr card))))) + +(defun cg-bid-trick-winner (plays trump led) + "Return the seat that wins a trick. +PLAYS is a list of (SEAT . CARD); TRUMP and LED as in `cg-bid-power'." + (car (cl-reduce + (lambda (best p) + (if (> (cg-bid-power (cdr p) trump led) + (cg-bid-power (cdr best) trump led)) + p best)) + plays))) + +(defun cg-bid-legal-cards (hand led trump) + "Return the legal subset of HAND given the LED suit and TRUMP. +When LED is nil (leading) every card is legal. Otherwise a player +must follow the led suit if able." + (if (null led) + hand + (let ((follow (cl-remove-if-not + (lambda (c) (eq (cg-bid-effective-suit c trump) led)) + hand))) + (or follow hand)))) + +(defun cg-bid-sort-hand (hand trump) + "Return HAND sorted for display: trumps first (by power), then by suit." + (sort (copy-sequence hand) + (lambda (a b) + (let* (( at (and (numberp trump) + (eq (cg-bid-effective-suit a trump) trump))) + (bt (and (numberp trump) + (eq (cg-bid-effective-suit b trump) trump))) + (aj (cg-bid-joker-p a)) + (bj (cg-bid-joker-p b))) + (cond + ((or aj bt) (and (not bj) (or aj bt) t)) + (t + (let ((ak (if (or aj at) -1 (car a))) + (bk (if (or bj bt) -1 (car b)))) + (if (/= ak bk) (< ak bk) + (> (cg-bid-power a (or trump 'nt) nil) + (cg-bid-power b (or trump 'nt) nil)))))))))) + + +(defun cg-bid--display-key (card trump) + "Return an ascending sort key for CARD to group a hand for display. +Trumps (and the Joker) sort first, strongest first; the remaining +suits are grouped spades, hearts, clubs, diamonds, high rank first." + (cond + ((cg-bid-joker-p card) 0) + ((and (numberp trump) (eq (cg-bid-effective-suit card trump) trump)) + (- 1000 (cg-bid-power card trump trump))) + (t (let ((si (cl-position (car card) [0 3 1 2]))) + (+ 2000 (* (or si 0) 100) (- 12 (cdr card))))))) + +(defun cg-bid-sort-display (hand trump) + "Return HAND sorted for display under TRUMP. +Trumps lead (strongest first), then each side suit runs high to low." + (sort (copy-sequence hand) + (lambda (a b) (< (cg-bid--display-key a trump) + (cg-bid--display-key b trump))))) + + +;;;; Game object and dealing + +(defclass cg-bid-game (cg-game) + ((name :initform "500 Bid")) + "The partnership trick-taking game 500.") + +(defvar cg-bid--human-seats '(0) + "List of seats controlled by a human player. South is seat 0.") + +(defconst cg-bid-seat-names ["South" "West" "North" "East"] + "Seat labels; partners sit opposite (0/2 and 1/3).") + +(defsubst cg-bid--human-p (seat) + "Return non-nil when SEAT is played by a human." + (memq seat cg-bid--human-seats)) + +(defsubst cg-bid--partner (seat) (mod (+ seat 2) 4)) +(defsubst cg-bid--team (seat) (mod seat 2)) ; 0 -> team 0 (S/N), 1 -> team 1 (W/E) + +(cl-defmethod cg-bid--deal ((game cg-bid-game) &optional dealer) + "Deal a fresh hand into GAME. DEALER defaults to East so South bids first." + (random t) + (let ((deck (cg-shuffle (cg-bid--full-deck))) + (hands (make-vector 4 nil)) + (dealer (or dealer 3))) + (dotimes (s 4) + (aset hands s (cl-loop repeat 10 collect (pop deck)))) + (cg-put game :hands hands) + (cg-put game :kitty deck) ; remaining 5 cards + (cg-put game :dealer dealer) + (cg-put game :phase 'auction) + (cg-put game :passed (make-vector 4 nil)) + (cg-put game :high-bid nil) + (cg-put game :high-bidder nil) + (cg-put game :bidder (mod (1+ dealer) 4)) ; left of dealer bids first + (cg-put game :contract nil) + (cg-put game :contractor nil) + (cg-put game :trick nil) + (cg-put game :last-trick nil) + (cg-put game :led nil) + (cg-put game :leader nil) + (cg-put game :tricks (make-vector 4 0)) + (cg-put game :ntricks 0) + (cg-put game :exposed nil) + (cg-put game :cursor 0) + (cg-put game :marks nil) + (cg-put game :hand-result nil) + (unless (cg-get game :scores) (cg-put game :scores (cons 0 0))) + (unless (plist-member (oref game env) :game-over) + (cg-put game :game-over nil)) + (unless (cg-get game :hand-no) (cg-put game :hand-no 0)) + (cg-put game :hand-no (1+ (cg-get game :hand-no))) + (cg-bid--note game "— Hand %d —" (cg-get game :hand-no)) + (cg-put game :message + (format "Auction: %s to bid." (aref cg-bid-seat-names + (cg-get game :bidder)))) + game)) + +(defun cg-bid--hand (game seat) (aref (cg-get game :hands) seat)) +(defun cg-bid--set-hand (game seat cards) (aset (cg-get game :hands) seat cards)) + + +;;;; Auction + +(defun cg-bid--legal-bids (game) + "Return the schedule entries that outbid the current high bid." + (let ((hv (if (cg-get game :high-bid) + (cg-bid-value (cg-get game :high-bid)) 0))) + (cl-remove-if-not (lambda (b) (> (cg-bid-value b) hv)) cg-bid-schedule))) + +(defun cg-bid--active-seats (game) + "Return the seats that have not passed." + (cl-loop for s below 4 + unless (aref (cg-get game :passed) s) collect s)) + +(defun cg-bid--next-bidder (game from) + "Return the next non-passed seat after FROM, or nil if none." + (cl-loop for i from 1 to 4 + for s = (mod (+ from i) 4) + unless (aref (cg-get game :passed) s) return s)) + +(defun cg-bid--note (game fmt &rest args) + "Append a narrative line (FMT with ARGS) to GAME's message log." + (cg-put game :log (cons (apply #'format fmt args) (cg-get game :log))) + (cg-put game :log-scroll 0)) + +(cl-defmethod cg-bid--auction-act ((game cg-bid-game) seat bid) + "Record SEAT's action: BID is a schedule entry, or nil to pass." + (if bid + (progn (cg-put game :high-bid bid) + (cg-put game :high-bidder seat) + (cg-put game :message + (format "%s bids %s." + (aref cg-bid-seat-names seat) (cg-bid-label bid))) + (cg-bid--note game "%s bids %s." + (aref cg-bid-seat-names seat) (cg-bid-label bid))) + (aset (cg-get game :passed) seat t) + (cg-put game :message (format "%s passes." (aref cg-bid-seat-names seat))) + (cg-bid--note game "%s passes." (aref cg-bid-seat-names seat))) + (let ((active (cg-bid--active-seats game))) + (cond + ;; everyone passed with no bid -> throw in + ((and (null (cg-get game :high-bid)) (null active)) + (cg-bid--deal game (mod (1+ (cg-get game :dealer)) 4)) + (cg-put game :message "All passed — redeal.")) + ;; one bidder left standing -> contract is set + ((and (cg-get game :high-bid) (= (length active) 1)) + (cg-bid--begin-contract game)) + (t + (cg-put game :bidder (cg-bid--next-bidder game seat)))))) + +(cl-defmethod cg-bid--begin-contract ((game cg-bid-game)) + "Set the winning contract and move to the kitty phase." + (let* ((contractor (cg-get game :high-bidder)) + (bid (cg-get game :high-bid))) + (cg-put game :contractor contractor) + (cg-put game :contract bid) + (cg-put game :phase 'kitty) + ;; contractor takes the kitty into hand + (cg-bid--set-hand game contractor + (append (cg-bid--hand game contractor) + (cg-get game :kitty))) + (cg-put game :kitty nil) + (cg-put game :leader contractor) + (cg-put game :turn contractor) + (cg-put game :message + (format "%s won the auction with %s (%s). Kitty taken." + (aref cg-bid-seat-names contractor) + (cg-bid-label bid) (cg-bid-name bid))) + (cg-bid--note game "%s won the bid: %s." + (aref cg-bid-seat-names contractor) (cg-bid-label bid)))) + + +;;;; Kitty discard + +(cl-defmethod cg-bid--discard ((game cg-bid-game) seat cards) + "Have SEAT discard CARDS (a list of 5) and start play." + (cg-bid--set-hand game seat + (cl-set-difference (cg-bid--hand game seat) cards + :test #'equal)) + (cg-put game :phase 'play) + (cg-put game :turn (cg-get game :contractor)) + (cg-put game :leader (cg-get game :contractor)) + (cg-put game :led nil) + (cg-put game :trick nil) + (cg-put game :cursor 0) + (cg-put game :message + (format "Play! %s leads." + (aref cg-bid-seat-names (cg-get game :contractor))))) + + +;;;; Seat order (a partner sits out during a misère) + +(defun cg-bid--misere-p (game) + "Return non-nil when the current contract is a nullo/misère." + (let ((c (cg-get game :contract))) (and c (cg-bid-nullo-p c)))) + +(defun cg-bid--sitter (game) + "Return the seat sitting out (contractor's partner) in a misère, else nil." + (and (cg-bid--misere-p game) + (cg-bid--partner (cg-get game :contractor)))) + +(defun cg-bid--in-play-p (game seat) + "Return non-nil when SEAT takes part in the current hand's play." + (not (eql seat (cg-bid--sitter game)))) + +(defun cg-bid--num-players (game) + "Return the number of seats playing to each trick (3 in misère, else 4)." + (if (cg-bid--misere-p game) 3 4)) + +(defun cg-bid--next-seat (game seat) + "Return the next in-play seat clockwise from SEAT." + (let ((n (mod (1+ seat) 4))) + (if (cg-bid--in-play-p game n) n (mod (1+ n) 4)))) + + +;;;; Trick play + +(cl-defmethod cg-bid--play ((game cg-bid-game) seat card) + "Have SEAT play CARD into the current trick and advance." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (led (cg-get game :led)) + (lead-p (null (cg-get game :trick)))) + ;; remove card from hand + (cg-bid--set-hand game seat + (cl-remove card (cg-bid--hand game seat) + :test #'equal :count 1)) + (cg-put game :trick (append (cg-get game :trick) (list (cons seat card)))) + (cg-bid--note game "%s %s the %s." + (aref cg-bid-seat-names seat) + (if lead-p "leads" "plays") + (cg-bid-card-string card)) + ;; establish led suit + (unless led + (setq led (cg-bid-effective-suit card trump)) + ;; joker led in no-trump nominates a suit + (when (and (eq led 'joker)) + (setq led (cg-bid--nominate-suit game seat))) + (cg-put game :led led)) + (if (= (length (cg-get game :trick)) (cg-bid--num-players game)) + (cg-bid--finish-trick game) + (cg-put game :turn (cg-bid--next-seat game seat))))) + +(defun cg-bid--nominate-suit (game seat) + "Choose the suit nominated when the Joker leads under no-trump." + (let ((hand (cg-bid--hand game seat))) + (if (cg-bid--human-p seat) + (let ((ch (read-char-choice + "Joker leads — nominate a suit [s]pades [c]lubs [d]iamonds [h]earts: " + '(?s ?c ?d ?h)))) + (cdr (assq ch '((?s . 0) (?c . 1) (?d . 2) (?h . 3))))) + ;; AI: nominate its longest non-joker suit + (let ((counts (make-vector 4 0))) + (dolist (c hand) + (unless (cg-bid-joker-p c) (cl-incf (aref counts (car c))))) + (let ((best 0)) + (dotimes (s 4) (when (> (aref counts s) (aref counts best)) + (setq best s))) + best))))) + +(cl-defmethod cg-bid--finish-trick ((game cg-bid-game)) + "Resolve the completed trick, award it, and set up the next." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (led (cg-get game :led)) + (plays (cg-get game :trick)) + (winner (cg-bid-trick-winner plays trump led))) + (cl-incf (aref (cg-get game :tricks) winner)) + (cg-put game :ntricks (1+ (cg-get game :ntricks))) + (cg-put game :last-trick plays) + (cg-put game :trick nil) + (cg-put game :led nil) + (cg-put game :leader winner) + (cg-put game :turn winner) + (cg-put game :message + (format "%s wins the trick (%s)." + (aref cg-bid-seat-names winner) + (mapconcat (lambda (p) (cg-bid-card-string (cdr p))) plays " "))) + (cg-bid--note game "%s wins the trick." (aref cg-bid-seat-names winner)) + ;; open misère: expose the contractor's hand after the first trick + (when (and (cg-bid-open-p (cg-get game :contract)) + (= (cg-get game :ntricks) 1)) + (cg-put game :exposed (cg-get game :contractor))) + ;; hand over after ten tricks + (when (= (cg-get game :ntricks) 10) + (cg-bid--score-hand game)))) + + +;;;; Scoring + +(cl-defmethod cg-bid--score-hand ((game cg-bid-game)) + "Score the completed hand per the Avondale schedule." + (let* ((bid (cg-get game :contract)) + (contractor (cg-get game :contractor)) + (cteam (cg-bid--team contractor)) + (tricks (cg-get game :tricks)) + (side (+ (aref tricks contractor) + (aref tricks (cg-bid--partner contractor)))) + (opp (- 10 side)) + (scores (cg-get game :scores)) + (delta-c 0) (delta-o 0) (made nil) result) + (cond + ((cg-bid-nullo-p bid) + ;; contractor alone must take no tricks (own-hand misère) + (setq made (zerop (aref tricks contractor))) + (setq delta-c (if made (cg-bid-value bid) (- (cg-bid-value bid))))) + (t + (setq made (>= side (cg-bid-tricks bid))) + (if made + (setq delta-c (if (and (= side 10) (< (cg-bid-value bid) 250)) + 250 (cg-bid-value bid))) + (setq delta-c (- (cg-bid-value bid)))) + (setq delta-o (* 10 opp)))) + ;; apply to teams + (let ((c (if (= cteam 0) (cons delta-c delta-o) (cons delta-o delta-c)))) + (cg-put game :scores (cons (+ (car scores) (car c)) + (+ (cdr scores) (cdr c))))) + (setq result + (format "%s %s %s: %s/%s took %d trick%s. %s %+d%s" + (aref cg-bid-seat-names contractor) + (if made "MADE" "was SET on") + (cg-bid-label bid) + (aref cg-bid-seat-names contractor) + (aref cg-bid-seat-names (cg-bid--partner contractor)) + side (if (= side 1) "" "s") + (if (= cteam 0) "You/North" "West/East") + delta-c + (if (and (not (cg-bid-nullo-p bid)) (> delta-o 0)) + (format ", opponents +%d" delta-o) ""))) + (cg-put game :phase 'done) + (cg-put game :hand-result result) + (cg-bid--note game "%s" result) + (let ((winner (cg-bid--check-gameover game made cteam))) + (cg-put game :message + (if winner + (format "%s — GAME OVER: %s WIN! Final — You/North %d, West/East %d. Press n for a new game." + result + (if (= winner 0) "You/North" "West/East") + (car (cg-get game :scores)) (cdr (cg-get game :scores))) + (concat result " — press n for the next hand.")))))) + +(cl-defmethod cg-bid--check-gameover ((game cg-bid-game) made cteam) + "End the game if a side has won (front door) or lost (back door). +Return the winning team, or nil. MADE and CTEAM describe the hand +just scored: a side wins only by reaching 500 on a made contract; +a side that sinks to -500 loses." + (let* ((sc (cg-get game :scores)) + (t0 (car sc)) (t1 (cdr sc)) + (winner + (cond + ((and made (>= (if (= cteam 0) t0 t1) 500)) cteam) + ((<= t0 -500) 1) + ((<= t1 -500) 0) + (t nil)))) + (when winner + (cg-put game :game-over winner) + (cg-put game :phase 'gameover)) + winner)) + + +;;;; Basic AI + +(defvar cg-bid-ai-policies (vector 'smart 'smart 'smart 'smart) + "Per-seat AI policy vector; each element is `smart' or `basic'.") + +(defvar cg-bid-ai-partner-help 1.0 + "Tricks the smart bidder assumes its partner will contribute.") + +(defun cg-bid--policy (seat) + "Return the AI policy symbol for SEAT." + (aref cg-bid-ai-policies seat)) + +;;; shared helpers + +(defun cg-bid--lowest (cards trump led) + "Return the weakest of CARDS given TRUMP and LED." + (car (sort (copy-sequence cards) + (lambda (a b) (< (cg-bid-power a trump led) + (cg-bid-power b trump led)))))) + +(defun cg-bid--highest (cards trump led) + "Return the strongest of CARDS given TRUMP and LED." + (car (sort (copy-sequence cards) + (lambda (a b) (> (cg-bid-power a trump led) + (cg-bid-power b trump led)))))) + +(defun cg-bid--trump-cards (hand trump) + "Return the cards of HAND that are trumps under TRUMP (incl. Joker, bowers)." + (cl-remove-if-not + (lambda (c) (or (cg-bid-joker-p c) + (and (numberp trump) (eq (cg-bid-effective-suit c trump) trump)))) + hand)) + +(defun cg-bid--suit-cards (hand suit trump) + "Return non-Joker cards of HAND whose effective suit is SUIT under TRUMP." + (cl-remove-if-not + (lambda (c) (and (not (cg-bid-joker-p c)) + (eq (cg-bid-effective-suit c trump) suit))) + hand)) + +;;; basic policy (original heuristics) + +(defun cg-bid--ai-estimate (hand trump) + "Rough trick estimate for HAND if TRUMP (0-3 or `nt') were the contract." + (let ((joker (cl-some #'cg-bid-joker-p hand)) + (aces 0) (kings 0) (trumps 0)) + (dolist (c hand) + (unless (cg-bid-joker-p c) + (cond + ((and (numberp trump) (eq (cg-bid-effective-suit c trump) trump)) + (cl-incf trumps)) + ((= (cdr c) 10) (cl-incf aces)) + ((= (cdr c) 9) (cl-incf kings))))) + (floor (+ trumps aces (* 0.5 kings) (if joker 1 0))))) + +(defun cg-bid--ai-best-contract (hand) + "Return (TRUMP . EST) for the strongest contract HAND suggests (basic)." + (let ((best (cons 'nt (cg-bid--ai-estimate hand 'nt)))) + (dotimes (s 4) + (let ((e (cg-bid--ai-estimate hand s))) + (when (> e (cdr best)) (setq best (cons s e))))) + best)) + +(defun cg-bid--ai-bid-basic (game seat) + "Pick and record a bid (or pass) for AI SEAT using the basic estimate." + (let* ((hand (cg-bid--hand game seat)) + (best (cg-bid--ai-best-contract hand)) + (trump (car best)) + (est (min 10 (cdr best))) + (maxval (cl-loop for b in cg-bid-schedule + when (and (eq (cg-bid-trump b) trump) + (= (cg-bid-tricks b) est)) + return (cg-bid-value b))) + (legal (cg-bid--legal-bids game)) + (choice (and maxval (>= est 6) + (car (cl-remove-if-not + (lambda (b) (<= (cg-bid-value b) maxval)) + legal))))) + (cg-bid--auction-act game seat choice))) + +(defun cg-bid--ai-discard-basic (game seat) + "Discard SEAT's five weakest cards (basic)." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (sorted (cg-bid-sort-hand (cg-bid--hand game seat) trump)) + (discard (last sorted 5))) + (cg-bid--discard game seat discard))) + +(defun cg-bid--ai-play-positive (game seat) + "Trick-play for AI SEAT under a suit or no-trump contract (basic)." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (led (cg-get game :led)) + (hand (cg-bid--hand game seat)) + (legal (cg-bid-legal-cards hand led trump)) + (plays (cg-get game :trick)) + card) + (if (null plays) + (setq card (or (cl-find-if + (lambda (c) (and (not (cg-bid-joker-p c)) (= (cdr c) 10) + (or (not (numberp trump)) + (/= (cg-bid-effective-suit c trump) trump)))) + legal) + (cg-bid--lowest legal trump led))) + (let* ((winner (cg-bid-trick-winner plays trump led)) + (partner-winning (= (cg-bid--partner seat) winner)) + (best-power (cg-bid-power (cdr (assq winner plays)) trump led))) + (if partner-winning + (setq card (cg-bid--lowest legal trump led)) + (let ((winners (cl-remove-if-not + (lambda (c) (> (cg-bid-power c trump led) best-power)) + legal))) + (setq card (if winners + (cg-bid--lowest winners trump led) + (cg-bid--lowest legal trump led))))))) + (cg-bid--play game seat card))) + +;;; smart policy + +(defun cg-bid--eval-suit (hand trump) + "Estimate tricks (float) for a suit TRUMP contract from HAND." + (let* ((trumps (cg-bid--trump-cards hand trump)) + (nt (length trumps)) + (high (cl-count-if (lambda (c) (>= (cg-bid-power c trump trump) 809)) trumps)) + (trump-tricks (+ high (max 0 (- nt 4)))) + (side 0.0) (ruffs 0.0)) + (dotimes (s 4) + (unless (= s trump) + (let* ((cs (cg-bid--suit-cards hand s trump)) + (len (length cs)) + (ranks (mapcar #'cdr cs))) + (when (memql 10 ranks) (cl-incf side 1.0)) + (when (memql 9 ranks) (cl-incf side (if (>= len 2) 0.5 0.25))) + (cond ((= len 0) (cl-incf ruffs 1.0)) + ((and (= len 1) (not (memql 10 ranks))) (cl-incf ruffs 0.5)))))) + (min 10.0 (+ trump-tricks side (min ruffs (float nt)))))) + +(defun cg-bid--eval-nt (hand) + "Estimate tricks (float) for a no-trump contract from HAND." + (let ((est (if (cl-some #'cg-bid-joker-p hand) 1.0 0.0))) + (dotimes (s 4) + (let* ((cs (cg-bid--suit-cards hand s 'nt)) + (len (length cs)) + (ranks (mapcar #'cdr cs))) + (when (memql 10 ranks) (cl-incf est 1.0)) + (when (memql 9 ranks) (cl-incf est (if (>= len 2) 0.5 0.25))) + (when (>= len 5) (cl-incf est (* 0.5 (- len 4)))))) + (min 10.0 est))) + +(defun cg-bid--best-smart (hand) + "Return (TRUMP . EST-float) for the best contract HAND suggests (smart)." + (let ((best (cons 'nt (cg-bid--eval-nt hand)))) + (dotimes (s 4) + (let ((e (cg-bid--eval-suit hand s))) + (when (> e (cdr best)) (setq best (cons s e))))) + best)) + +(defun cg-bid--ai-bid-smart (game seat) + "Pick and record a bid (or pass) for AI SEAT using the smart evaluation." + (let* ((hand (cg-bid--hand game seat)) + (best (cg-bid--best-smart hand)) + (trump (car best)) + (est (min 10 (floor (+ (cdr best) cg-bid-ai-partner-help)))) + (maxval (cl-loop for b in cg-bid-schedule + when (and (eq (cg-bid-trump b) trump) + (= (cg-bid-tricks b) est)) + return (cg-bid-value b))) + (legal (cg-bid--legal-bids game)) + (choice (and maxval (>= est 6) + (car (cl-remove-if-not + (lambda (b) (<= (cg-bid-value b) maxval)) + legal))))) + (cg-bid--auction-act game seat choice))) + +(defun cg-bid--ai-discard-smart (game seat) + "Discard to keep trumps and aces and to void short side suits for ruffs." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (hand (cg-bid--hand game seat)) + (cand '())) + (dolist (c hand) + (unless (or (cg-bid-joker-p c) (= (cdr c) 10) + (and (numberp trump) (eq (cg-bid-effective-suit c trump) trump))) + (push c cand))) + (let ((bysuit (make-vector 4 0))) + (dolist (c cand) (cl-incf (aref bysuit (car c)))) + (setq cand (sort cand + (lambda (a b) + (if (/= (aref bysuit (car a)) (aref bysuit (car b))) + (< (aref bysuit (car a)) (aref bysuit (car b))) + (< (cdr a) (cdr b)))))) + (let ((discard (if (>= (length cand) 5) + (cl-subseq cand 0 5) + (last (cg-bid-sort-hand hand trump) 5)))) + (cg-bid--discard game seat discard))))) + +(defun cg-bid--lead-low-long (hand trump legal) + "Lead the lowest card of the player's longest side suit, from LEGAL." + (let ((best-suit nil) (best-len -1)) + (dotimes (s 4) + (unless (and (numberp trump) (= s trump)) + (let ((len (length (cg-bid--suit-cards hand s trump)))) + (when (> len best-len) (setq best-len len best-suit s))))) + (let ((cs (and best-suit + (cl-remove-if-not + (lambda (c) (and (not (cg-bid-joker-p c)) + (eq (cg-bid-effective-suit c trump) best-suit))) + legal)))) + (cg-bid--lowest (or cs legal) trump nil)))) + +(defun cg-bid--ai-play-smart (game seat) + "Trick-play for AI SEAT under a suit/NT contract with simple tactics: +declarer draws trumps and cashes aces; everyone wins as cheaply as +possible and never overtakes a partner who is already winning." + (let* ((trump (cg-bid-trump (cg-get game :contract))) + (led (cg-get game :led)) + (hand (cg-bid--hand game seat)) + (legal (cg-bid-legal-cards hand led trump)) + (plays (cg-get game :trick)) + (contractor (cg-get game :contractor)) + (declarer-side (= (cg-bid--team seat) (cg-bid--team contractor))) + card) + (cond + ((null plays) + (let* ((trumps (and (numberp trump) (cg-bid--trump-cards hand trump))) + (hi (cl-count-if (lambda (c) (>= (cg-bid-power c trump trump) 809)) + (or trumps '())))) + (setq card + (cond + ((and declarer-side (numberp trump) trumps + (or (>= (length trumps) 4) (>= hi 2))) + (cg-bid--highest trumps trump trump)) + ((cl-find-if (lambda (c) + (and (not (cg-bid-joker-p c)) (= (cdr c) 10) + (or (not (numberp trump)) + (/= (cg-bid-effective-suit c trump) trump)))) + legal)) + (t (cg-bid--lead-low-long hand trump legal)))))) + (t + (let* ((winner (cg-bid-trick-winner plays trump led)) + (partner-winning (= (cg-bid--partner seat) winner)) + (best-power (cg-bid-power (cdr (assq winner plays)) trump led))) + (setq card + (if partner-winning + (cg-bid--lowest legal trump led) + (let ((winners (cl-remove-if-not + (lambda (c) (> (cg-bid-power c trump led) best-power)) + legal))) + (if winners (cg-bid--lowest winners trump led) + (cg-bid--lowest legal trump led)))))))) + (cg-bid--play game seat card))) + +;;; dispatch + +(cl-defmethod cg-bid--ai-bid ((game cg-bid-game) seat) + "Pick and record a bid for AI SEAT per its policy." + (if (eq (cg-bid--policy seat) 'smart) + (cg-bid--ai-bid-smart game seat) + (cg-bid--ai-bid-basic game seat))) + +(cl-defmethod cg-bid--ai-discard ((game cg-bid-game) seat) + "Have AI SEAT exchange the kitty per its policy." + (if (eq (cg-bid--policy seat) 'smart) + (cg-bid--ai-discard-smart game seat) + (cg-bid--ai-discard-basic game seat))) + +(cl-defmethod cg-bid--ai-play ((game cg-bid-game) seat) + "Choose and play a card for AI SEAT per its policy." + (cond ((cg-bid--misere-p game) (cg-bid--ai-play-misere game seat)) + ((eq (cg-bid--policy seat) 'smart) (cg-bid--ai-play-smart game seat)) + (t (cg-bid--ai-play-positive game seat)))) + +(defun cg-bid--ai-play-misere (game seat) + "Trick-play for AI SEAT during a misère. +The contractor sheds its highest card that still loses (or ducks +lowest when leading); defenders simply play low." + (let* ((trump 'nullo) + (led (cg-get game :led)) + (hand (cg-bid--hand game seat)) + (legal (cg-bid-legal-cards hand led trump)) + (plays (cg-get game :trick)) + (contractor (cg-get game :contractor)) + card) + (cond + ((/= seat contractor) + (setq card (cg-bid--lowest legal trump led))) + ((null plays) + (setq card (cg-bid--lowest legal trump led))) + (t + (let* ((wseat (cg-bid-trick-winner plays trump led)) + (bestp (cg-bid-power (cdr (assq wseat plays)) trump led)) + (losers (cl-remove-if-not + (lambda (c) (< (cg-bid-power c trump led) bestp)) legal))) + (setq card (cg-bid--highest (or losers legal) trump led))))) + (cg-bid--play game seat card))) + + +;;;; Driver: run AI until the human must act + +(defun cg-bid--ai-step (game) + "Perform one pending AI action in GAME. Return non-nil if it acted." + (pcase (cg-get game :phase) + ('auction (unless (cg-bid--human-p (cg-get game :bidder)) + (cg-bid--ai-bid game (cg-get game :bidder)) t)) + ('kitty (unless (cg-bid--human-p (cg-get game :contractor)) + (cg-bid--ai-discard game (cg-get game :contractor)) t)) + ('play (unless (cg-bid--human-p (cg-get game :turn)) + (cg-bid--ai-play game (cg-get game :turn)) t)) + (_ nil))) + +(cl-defmethod cg-bid--run ((game cg-bid-game)) + "Advance GAME through AI actions until a human is needed or it ends." + (let ((guard 0)) + (while (and (< (cl-incf guard) 400) (cg-bid--ai-step game))))) + +(provide 'cg-bid) +;;; cg-bid.el ends here diff --git a/cg-core.el b/cg-core.el new file mode 100644 index 0000000..58923c8 --- /dev/null +++ b/cg-core.el @@ -0,0 +1,142 @@ +;;; cg-core.el --- Shared engine core for card games -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; A small EIEIO scaffolding shared by the games in this package. It +;; provides the abstract `cg-game' class with a plist "environment" for +;; mutable per-game state, the `cg-render' and `cg-won-p' generics, and +;; a handful of card and display utilities (suit glyphs, colour +;; helpers, a shuffle, and common faces). +;; +;; Cards are normally represented as a cons cell (SUIT . RANK) with suit +;; indices 0=Spades 1=Clubs 2=Diamonds 3=Hearts; games define their own +;; rank scales. nil conventionally denotes an empty slot. + +;;; Code: + +(require 'cl-lib) +(require 'eieio) + +(defgroup card-games nil + "Play card games in Emacs." + :group 'games + :prefix "cg-") + + +;;;; Engine base + +(defcustom cg-keys 'emacs + "Keybinding scheme for the card games. +`emacs' follows Emacs conventions (arrow keys to move, RET to act, +g to redraw). `classic' additionally enables vi-style hjkl movement +and SPC as an action key. Takes effect the next time a game starts." + :type '(choice (const :tag "Emacs conventions" emacs) + (const :tag "Classic (adds hjkl, SPC)" classic)) + :group 'card-games) + +(defclass cg-game () + ((name :initarg :name :initform "game" :type string + :documentation "Human-readable game name.") + (env :initarg :env :initform nil + :documentation "Mutable per-game data, stored as a plist.")) + "Abstract base class for card games." + :abstract t) + +(cl-defgeneric cg-render (game) + "Return a propertized string depicting GAME.") + +(cl-defgeneric cg-won-p (game) + "Return non-nil when GAME has been won.") + +(cl-defmethod cg-get ((game cg-game) key) + "Return value for KEY in GAME's environment." + (plist-get (oref game env) key)) + +(cl-defmethod cg-put ((game cg-game) key value) + "Set KEY to VALUE in GAME's environment and return VALUE." + (oset game env (plist-put (oref game env) key value)) + value) + + +;;;; Cards and colours + +(defconst cg-suits ["♠" "♣" "♦" "♥"] + "Suit glyphs indexed 0..3: spades, clubs, diamonds, hearts.") + +(defconst cg-suit-names ["Spades" "Clubs" "Diamonds" "Hearts"] + "Suit names indexed to match `cg-suits'.") + +(defsubst cg-red-suit-p (suit) + "Return non-nil when SUIT index denotes a red suit." + (memq suit '(2 3))) + +(defsubst cg-sister-suit (suit) + "Return the other suit index of the same colour as SUIT." + (pcase suit (0 1) (1 0) (2 3) (3 2))) + +(defun cg-shuffle (seq) + "Return a new list with the elements of SEQ in random order." + (let* ((v (vconcat seq)) + (n (length v))) + (dotimes (i n) + (let ((j (+ i (random (- n i))))) + (cl-rotatef (aref v i) (aref v j)))) + (append v nil))) + + +;;;; Shared faces + +(defface cg-red-suit '((t :foreground "red3")) + "Face for red-suited cards." :group 'card-games) + +(defface cg-cursor '((t :inverse-video t)) + "Face for the cell or card under the cursor." :group 'card-games) + +(defface cg-gap '((t :foreground "gray50")) + "Face for an empty slot." :group 'card-games) + +(defface cg-hint '((t :foreground "green3" :weight bold)) + "Face for a valid move target (a fillable gap)." :group 'card-games) + +(defun cg-color (face attribute fallback) + "Return FACE's ATTRIBUTE colour if usable on this display, else FALLBACK. +Degrades gracefully when there is no theme/frame (e.g. in a terminal +or batch), so callers always get a drawable colour string." + (let ((c (ignore-errors (face-attribute face attribute nil t)))) + (if (and (stringp c) + (not (string-prefix-p "unspecified" c)) + (ignore-errors (color-defined-p c))) + c + fallback))) + +(defun cg-scale () + "Return the SVG card scale factor for the current buffer. +Tracks `text-scale-increase'/`text-scale-decrease' via the buffer-local +`text-scale-mode-amount', so enlarging the text enlarges the cards." + (let ((amt (if (boundp 'text-scale-mode-amount) text-scale-mode-amount 0))) + (max 0.4 (min 4.0 (expt 1.15 amt))))) + +(provide 'cg-core) +;;; cg-core.el ends here diff --git a/cg-gaps.el b/cg-gaps.el new file mode 100644 index 0000000..f21a59a --- /dev/null +++ b/cg-gaps.el @@ -0,0 +1,850 @@ +;;; cg-gaps.el --- Gaps-style row solitaires (Montana, Hell's Half-Acre) -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; The "gaps" family of solitaires: 48 cards dealt into four rows of +;; thirteen with four gaps. A gap is filled by the card one rank along +;; from the card to its left, of the same suit; the head gap of a row +;; takes the anchor rank in any suit. +;; +;; Two variants ship, demonstrating how a new game is *derived* by +;; subclassing the abstract `cg-gaps-game' and overriding two methods +;; (`cg-gaps--head' and `cg-gaps--step'): +;; +;; `cg-montana' Gaps / Montana: Two at the head, rows build +;; UP 2 3 4 ... K; nothing follows a King. +;; `cg-hells-half-acre' Hell's Half-Acre: King at the head, rows +;; build DOWN K Q J ... 2; nothing follows a Two. +;; +;; When stuck you may redeal (twice): each correct run from the head +;; stays, a gap opens just past it, and the rest are reshuffled. +;; +;; Renders as UNICODE text in a terminal and as SVG cards on a graphical +;; display; fillable gaps are highlighted. Play via `M-x card-game' or +;; the commands above. + +;;; Code: + +(require 'cg-core) +(require 'cg-svg) + + +;;;; Cards + +(defconst cg-gaps-ranks + ["2" "3" "4" "5" "6" "7" "8" "9" "10" "J" "Q" "K"] + "Rank labels indexed 0..11 (Two through King).") + +(defconst cg-gaps-rank-names + ["Two" "Three" "Four" "Five" "Six" "Seven" "Eight" "Nine" + "Ten" "Jack" "Queen" "King"] + "Full rank names indexed to match `cg-gaps-ranks'.") + +;; A card is a cons cell (SUIT . RANK); nil denotes a gap. + +(defsubst cg-gaps-red-p (card) + "Return non-nil when CARD is a red suit (diamonds or hearts)." + (and card (cg-red-suit-p (car card)))) + +(defun cg-gaps-card-string (card) + "Return a short string for CARD, or a dot for a gap (nil)." + (if (null card) + "·" + (concat (aref cg-gaps-ranks (cdr card)) + (aref cg-suits (car card))))) + + +;;;; Games — an abstract base and two subclasses + +(defclass cg-gaps-game (cg-game) + ((name :initform "Gaps")) + "Abstract base for gaps-style row solitaires. +Subclasses set the head rank and build direction by overriding +`cg-gaps--head' and `cg-gaps--step'." + :abstract t) + +(cl-defgeneric cg-gaps--head (game) + "Return the rank index that anchors the head (left) of each row.") +(cl-defgeneric cg-gaps--step (game) + "Return the per-column rank increment: +1 ascending, -1 descending.") +(cl-defgeneric cg-gaps--vname (game) + "Return the human-readable variant name for GAME.") + +(defclass cg-montana-game (cg-gaps-game) + ((name :initform "Montana")) + "Gaps / Montana: a Two anchors the head; rows build up 2..K.") +(cl-defmethod cg-gaps--head ((_ cg-montana-game)) 0) +(cl-defmethod cg-gaps--step ((_ cg-montana-game)) 1) +(cl-defmethod cg-gaps--vname ((_ cg-montana-game)) "Gaps (Montana)") + +(defclass cg-acre-game (cg-gaps-game) + ((name :initform "Hell's Half-Acre")) + "Hell's Half-Acre: a King anchors the head; rows build down K..2.") +(cl-defmethod cg-gaps--head ((_ cg-acre-game)) 11) +(cl-defmethod cg-gaps--step ((_ cg-acre-game)) -1) +(cl-defmethod cg-gaps--vname ((_ cg-acre-game)) "Hell's Half-Acre") + +(defalias 'cg-gaps--shuffle 'cg-shuffle) + +(defun cg-gaps--full-deck () + "Return the 48 playable cards (Two..King in every suit)." + (cl-loop for s below 4 + append (cl-loop for r below 12 collect (cons s r)))) + +(cl-defmethod cg-gaps--deal ((game cg-gaps-game)) + "Deal a fresh layout into GAME." + (random t) + (let ((cells (cg-gaps--shuffle (append (cg-gaps--full-deck) + (make-list 4 nil)))) + (board (make-vector 4 nil))) + (dotimes (r 4) + (let ((row (make-vector 13 nil))) + (dotimes (c 13) + (aset row c (pop cells))) + (aset board r row))) + (cg-put game :board board) + (cg-put game :moves 0) + (cg-put game :redeals 2) + (cg-put game :cursor (cons 0 0)) + (cg-put game :history nil) + (cg-put game :message + (format "Fill the gaps: each row one suit, %s. RET on a gap. ? = help." + (if (> (cg-gaps--step game) 0) "2 up to K" "K down to 2"))) + game)) + +(defun cg-gaps--cell (board r c) + "Return the card at row R column C of BOARD (nil for a gap)." + (aref (aref board r) c)) + +(cl-defmethod cg-gaps--needed ((game cg-gaps-game) board r c) + "Return what may fill the gap at R, C of BOARD for GAME. +Returns the symbol `head' for a head gap, a (SUIT . RANK) card for any +other fillable gap, or nil if nothing fits." + (if (= c 0) + 'head + (let ((left (cg-gaps--cell board r (1- c)))) + (if (null left) + nil + (let ((nr (+ (cdr left) (cg-gaps--step game)))) + (and (>= nr 0) (<= nr 11) (cons (car left) nr))))))) + +(defun cg-gaps--find (board card) + "Return (ROW . COL) of CARD in BOARD, or nil if absent." + (catch 'hit + (dotimes (r 4) + (dotimes (c 13) + (when (equal (cg-gaps--cell board r c) card) + (throw 'hit (cons r c))))) + nil)) + +(defun cg-gaps--copy-board (board) + "Return a shallow copy of BOARD safe to mutate cell-by-cell." + (apply #'vector (mapcar #'copy-sequence (append board nil)))) + +(cl-defmethod cg-gaps--save-undo ((game cg-gaps-game)) + "Push the current state of GAME onto its undo history." + (cg-put game :history + (cons (list (cg-gaps--copy-board (cg-get game :board)) + (cg-get game :moves) + (cg-get game :redeals)) + (cg-get game :history)))) + +(cl-defmethod cg-gaps--do-move ((game cg-gaps-game) r c card) + "Move CARD into the gap at R, C of GAME. Return non-nil on success." + (let* ((board (cg-get game :board)) + (loc (cg-gaps--find board card))) + (if (not loc) + (progn (cg-put game :message + (format "The %s is not on the board?!" + (cg-gaps-card-string card))) + nil) + (cg-gaps--save-undo game) + (setf (aref (aref board (car loc)) (cdr loc)) nil) + (setf (aref (aref board r) c) card) + (cg-put game :moves (1+ (cg-get game :moves))) + (cg-put game :message (format "Moved %s." (cg-gaps-card-string card))) + t))) + +(cl-defmethod cg-gaps--fill ((game cg-gaps-game) r c) + "Try to fill the gap at R, C of GAME. Return non-nil on success." + (let* ((board (cg-get game :board)) + (cell (cg-gaps--cell board r c))) + (cond + (cell + (cg-put game :message "That cell is not a gap.") nil) + (t + (let ((needed (cg-gaps--needed game board r c))) + (cond + ((null needed) + (cg-put game :message "Nothing can fill that gap.") nil) + ((eq needed 'head) + (let ((suit (cg-gaps--read-head game))) + (and suit (cg-gaps--do-move game r c (cons suit (cg-gaps--head game)))))) + (t + (cg-gaps--do-move game r c needed)))))))) + +(cl-defmethod cg-gaps--read-head ((game cg-gaps-game)) + "Prompt for the suit of the head card of GAME. Return suit 0..3 or nil." + (let* ((name (aref cg-gaps-rank-names (cg-gaps--head game))) + (ch (read-char-choice + (format "Head gap — which %s? [s]pades [c]lubs [d]iamonds [h]earts (q=cancel): " + name) + '(?s ?c ?d ?h ?q)))) + (cdr (assq ch '((?s . 0) (?c . 1) (?d . 2) (?h . 3)))))) + +(cl-defmethod cg-won-p ((game cg-gaps-game)) + "Return non-nil when every row of GAME is a full suited run with a trailing gap." + (let ((board (cg-get game :board)) + (head (cg-gaps--head game)) + (step (cg-gaps--step game))) + (catch 'no + (dotimes (r 4) + (let* ((row (aref board r)) + (c0 (aref row 0))) + (unless c0 (throw 'no nil)) + (let ((suit (car c0))) + (dotimes (c 12) + (let ((cell (aref row c))) + (unless (and cell (= (car cell) suit) + (= (cdr cell) (+ head (* c step)))) + (throw 'no nil)))) + (when (aref row 12) (throw 'no nil))))) + t))) + +(cl-defmethod cg-gaps--stuck-p ((game cg-gaps-game)) + "Return non-nil when no gap of GAME can currently be filled." + (null (cg-gaps--hints game))) + +(cl-defmethod cg-gaps--hints ((game cg-gaps-game)) + "Return the list of (ROW . COL) gaps of GAME that can be filled now." + (let ((board (cg-get game :board)) + (hints nil)) + (dotimes (r 4) + (dotimes (c 13) + (when (and (null (cg-gaps--cell board r c)) + (cg-gaps--needed game board r c)) + (push (cons r c) hints)))) + hints)) + +(cl-defmethod cg-gaps--prefix-len ((game cg-gaps-game) board r) + "Return the length of the correct run at the head of row R of BOARD." + (let ((row (aref board r)) + (head (cg-gaps--head game)) + (step (cg-gaps--step game)) + (len 0)) + (let ((c0 (aref row 0))) + (when (and c0 (= (cdr c0) head)) + (let ((suit (car c0)) (i 0) (cont t)) + (while (and cont (< i 12)) + (let ((cell (aref row i))) + (if (and cell (= (car cell) suit) + (= (cdr cell) (+ head (* i step)))) + (setq i (1+ i)) + (setq cont nil)))) + (setq len i)))) + len)) + +(cl-defmethod cg-gaps--do-redeal ((game cg-gaps-game)) + "Gather misplaced cards of GAME, reshuffle, and lay them back." + (let* ((board (cg-get game :board)) + (lens (make-vector 4 0)) + (kept nil)) + (dotimes (r 4) + (let ((len (cg-gaps--prefix-len game board r))) + (aset lens r len) + (dotimes (i len) (push (cg-gaps--cell board r i) kept)))) + (let* ((remaining + (cg-gaps--shuffle + (cl-remove-if (lambda (card) (cl-member card kept :test #'equal)) + (cg-gaps--full-deck)))) + (new (make-vector 4 nil))) + (dotimes (r 4) + (let ((row (make-vector 13 nil)) + (len (aref lens r))) + (dotimes (i len) + (aset row i (cg-gaps--cell board r i))) + ;; column LEN stays a gap. + (cl-loop for c from (1+ len) below 13 + do (aset row c (pop remaining))) + (aset new r row))) + (cg-put game :board new)))) + + +;;;; Rendering + +(defun cg-gaps--header (game) + "Return the header text for GAME." + (format " ♠♣ %s ♦♥\n Moves: %-4d Redeals left: %d\n\n" + (cg-gaps--vname game) (cg-get game :moves) (cg-get game :redeals))) + +(defun cg-gaps--footer (game) + "Return the footer text (just the current message) for GAME. +The control line is inserted separately by `cg-gaps--insert-controls', +where each key hint is itself the clickable button." + (format "\n %s\n" (cg-get game :message))) + +(cl-defmethod cg-render ((game cg-gaps-game)) + "Return a propertized string depicting GAME (console rendering)." + (let* ((board (cg-get game :board)) + (cursor (cg-get game :cursor)) + (cr (car cursor)) + (cc (cdr cursor)) + (hints (cg-gaps--hints game)) + (out (list))) + (push (cg-gaps--header game) out) + (dotimes (r 4) + (dotimes (c 13) + (let* ((cell (cg-gaps--cell board r c)) + (gapp (null cell)) + (hintp (and gapp (member (cons r c) hints))) + (str (cond ((not gapp) (cg-gaps-card-string cell)) + (hintp "+") + (t "·"))) + (faces nil)) + (when (cg-gaps-red-p cell) (push 'cg-red-suit faces)) + (when hintp (push 'cg-hint faces)) + (when (and gapp (not hintp)) (push 'cg-gap faces)) + (when (and (= r cr) (= c cc)) (push 'cg-cursor faces)) + (let ((content (propertize (format "%3s" str) + 'face (or faces 'default)))) + (push (propertize (concat " " content) + 'cg-cell (cons r c) + 'mouse-face 'highlight) + out)))) + (push "\n" out)) + (push (cg-gaps--footer game) out) + (apply #'concat (nreverse out)))) + +(defun cg-gaps--board-specs (board) + "Return BOARD as rows of SVG card specs for `cg-svg-grid-svg'." + (let ((rows nil)) + (dotimes (r 4) + (let ((row nil)) + (dotimes (c 13) + (let ((cell (cg-gaps--cell board r c))) + (push (and cell (cons (aref cg-gaps-ranks (cdr cell)) (car cell))) + row))) + (push (nreverse row) rows))) + (nreverse rows))) + +(defconst cg-gaps--svg-card-w 46 "Base card width used by the SVG board.") +(defconst cg-gaps--svg-card-h 64 "Base card height used by the SVG board.") +(defconst cg-gaps--svg-gap 6 "Pixel gap between cards on the SVG board.") +(defconst cg-gaps--svg-pad 10 "Margin around the SVG board.") + +(defcustom cg-gaps-svg-ui nil + "When non-nil (and on a graphical display), render the gaps board as a +single full-buffer SVG: the board fills the window with a status/controls +panel down the left side, mirroring the 500 full-SVG UI. Toggle with `v'." + :type 'boolean :group 'cg-svg) + +(defcustom cg-gaps-svg-fill t + "When non-nil, size the full-SVG gaps UI to fill the window and re-fit on +window changes. Only used when `cg-gaps-svg-ui' is enabled." + :type 'boolean :group 'cg-svg) + +(defun cg-gaps--insert-graphical (game) + "Insert the GUI (SVG) depiction of GAME into the current buffer." + (insert (cg-gaps--header game)) + (let ((cg-svg-card-width cg-gaps--svg-card-w) + (cg-svg-card-height cg-gaps--svg-card-h) + (cg-svg-card-gap cg-gaps--svg-gap)) + (insert-image + (cg-svg-image + (cg-svg-grid-svg (cg-gaps--board-specs (cg-get game :board)) + :cursor (cg-get game :cursor) + :hints (cg-gaps--hints game) + :pad cg-gaps--svg-pad) + (cg-scale)))) + (insert "\n") + (insert (cg-gaps--footer game))) + + +;;;; Interaction + +(defvar-local cg-gaps--game nil + "The `cg-gaps-game' object played in the current buffer.") + +(defun cg-gaps--goto-cell (r c) + "Move point onto the rendered cell at row R column C, if present." + (let ((target (cons r c)) + (pos (point-min)) + (found nil)) + (while (and pos (not found)) + (when (equal (get-text-property pos 'cg-cell) target) + (setq found pos)) + (setq pos (next-single-property-change pos 'cg-cell))) + (when found (goto-char (1+ found))))) + +(defun cg-gaps--key-button (key word cmd help) + "Insert a control where the KEY hint itself is the button running CMD. +Shown as \"key word\" (e.g. \"r redeal\"); HELP is the tooltip." + (insert-text-button (format "%s %s" key word) + 'action (lambda (_) (call-interactively cmd)) + 'help-echo help 'follow-link t 'face 'link) + (insert " ")) + +(defun cg-gaps--insert-controls () + "Insert a single control line. +Movement keys are a plain hint; the action keys double as their own +buttons (the keyboard hint *is* the button)." + (insert " ") + (insert (propertize "←→↑↓ move " 'face 'shadow)) + (cg-gaps--key-button "RET" "fill" #'cg-gaps-fill "Fill the gap under the cursor") + (cg-gaps--key-button "r" "redeal" #'cg-gaps-redeal "Reshuffle the misplaced cards") + (cg-gaps--key-button "u" "undo" #'cg-gaps-undo "Undo the last move") + (cg-gaps--key-button "n" "new" #'cg-gaps-new "Deal a new game") + (cg-gaps--key-button "?" "help" #'cg-gaps-help "Show the rules and keys") + (insert "\n")) + +(defun cg-gaps--redisplay () + "Redraw the current Gaps buffer. +Full-buffer SVG when `cg-gaps-svg-ui'; otherwise an inline SVG board (or +UNICODE text on a terminal), each followed by the single control line." + (let ((game cg-gaps--game) + (inhibit-read-only t)) + (setq-local mode-line-process (cg-gaps--mode-line game)) + (erase-buffer) + (cond + ((and cg-gaps-svg-ui (display-graphic-p)) + (cg-gaps--insert-svg-ui game)) + ((display-graphic-p) + (cg-gaps--insert-graphical game) + (cg-gaps--insert-controls)) + (t + (insert (cg-render game)) + (cg-gaps--insert-controls))) + (if (display-graphic-p) + (goto-char (point-min)) + (let ((cur (cg-get game :cursor))) + (cg-gaps--goto-cell (car cur) (cdr cur)))))) + +(defun cg-gaps--move (dr dc) + "Move the cursor by DR rows and DC columns, then redisplay." + (let* ((game cg-gaps--game) + (cur (cg-get game :cursor)) + (r (min 3 (max 0 (+ (car cur) dr)))) + (c (min 12 (max 0 (+ (cdr cur) dc))))) + (cg-put game :cursor (cons r c)) + (cg-gaps--redisplay))) + +(defun cg-gaps-left () "Move cursor left." (interactive) (cg-gaps--move 0 -1)) +(defun cg-gaps-right () "Move cursor right." (interactive) (cg-gaps--move 0 1)) +(defun cg-gaps-up () "Move cursor up." (interactive) (cg-gaps--move -1 0)) +(defun cg-gaps-down () "Move cursor down." (interactive) (cg-gaps--move 1 0)) + +(defun cg-gaps--after-move () + "Check for a win or a stuck position and report it." + (let ((game cg-gaps--game)) + (cond + ((cg-won-p game) + (cg-put game :message + (format "\U0001F389 Solved in %d moves! Press n for a new game." + (cg-get game :moves)))) + ((cg-gaps--stuck-p game) + (cg-put game :message + (if (> (cg-get game :redeals) 0) + (format "Stuck! Press r to redeal (%d left)." + (cg-get game :redeals)) + "Stuck, and no redeals left. Press n for a new game.")))) + (cg-gaps--redisplay) + (message "%s" (cg-get game :message)))) + +(defun cg-gaps-fill () + "Fill the gap under the cursor." + (interactive) + (let* ((game cg-gaps--game) + (cur (cg-get game :cursor))) + (if (cg-gaps--fill game (car cur) (cdr cur)) + (cg-gaps--after-move) + (cg-gaps--redisplay)))) + +(defun cg-gaps-redeal () + "Reshuffle and redeal the misplaced cards, if redeals remain." + (interactive) + (let ((game cg-gaps--game)) + (if (<= (cg-get game :redeals) 0) + (progn (cg-put game :message "No redeals left.") + (cg-gaps--redisplay)) + (cg-gaps--save-undo game) + (cg-gaps--do-redeal game) + (cg-put game :redeals (1- (cg-get game :redeals))) + (cg-put game :message + (format "Redealt. %d redeals left." (cg-get game :redeals))) + (cg-gaps--after-move)))) + +(defun cg-gaps-undo () + "Undo the last move or redeal." + (interactive) + (let* ((game cg-gaps--game) + (hist (cg-get game :history))) + (if (null hist) + (progn (cg-put game :message "Nothing to undo.") + (cg-gaps--redisplay)) + (let ((snap (car hist))) + (cg-put game :board (nth 0 snap)) + (cg-put game :moves (nth 1 snap)) + (cg-put game :redeals (nth 2 snap)) + (cg-put game :history (cdr hist)) + (cg-put game :message "Undone.") + (cg-gaps--redisplay))))) + +(defun cg-gaps-new () + "Start a new game in the current buffer." + (interactive) + (cg-gaps--deal cg-gaps--game) + (cg-gaps--redisplay)) + +(defun cg-gaps--xy->cell (px py) + "Map pixel coordinates PX, PY on the SVG board to a (ROW . COL), or nil." + (let* ((w cg-gaps--svg-card-w) (h cg-gaps--svg-card-h) + (g cg-gaps--svg-gap) (pad cg-gaps--svg-pad)) + (when (and (>= px pad) (>= py pad)) + (let* ((col (/ (- px pad) (+ w g))) + (row (/ (- py pad) (+ h g))) + (xin (- px pad (* col (+ w g)))) + (yin (- py pad (* row (+ h g))))) + (when (and (< col 13) (< row 4) (<= xin w) (<= yin h)) + (cons row col)))))) + +(defun cg-gaps-mouse (event) + "Fill the gap clicked by EVENT (or move the cursor there). +Dispatches to the full-SVG UI when active; otherwise hit-tests the inline +SVG board (pixel) or the text grid (text property)." + (interactive "e") + (let ((start (event-start event))) + (if (and cg-gaps-svg-ui (display-graphic-p) (posn-image start)) + (cg-gaps--svg-ui-click start) + (let ((cell (if (and (display-graphic-p) (posn-image start)) + (let ((xy (posn-object-x-y start)) (s (cg-scale))) + (and xy (cg-gaps--xy->cell (round (/ (car xy) s)) + (round (/ (cdr xy) s))))) + (let ((pos (posn-point start))) + (and pos (get-text-property pos 'cg-cell)))))) + (when cell + (cg-put cg-gaps--game :cursor cell) + (cg-gaps-fill)))))) + +(defun cg-gaps-help () + "Show a one-line reminder of the controls." + (interactive) + (let ((game cg-gaps--game)) + (message "%s" + (format "%s: move to a highlighted gap and RET to fill it (a %s anchors the head). r=redeal u=undo n=new q=quit." + (if game (cg-gaps--vname game) "Gaps") + (if game (aref cg-gaps-rank-names (cg-gaps--head game)) "card"))))) + +(defun cg-gaps--mode-line (game) + "Return the mode-line status string for GAME." + (cond ((cg-won-p game) " [Solved!]") + ((cg-gaps--stuck-p game) + (if (> (cg-get game :redeals) 0) " [Stuck — r to redeal]" " [Stuck]")) + (t (format " [moves %d · redeals %d]" + (cg-get game :moves) (cg-get game :redeals))))) + +(defun cg-gaps-zoom-in () + "Enlarge the cards." (interactive) (text-scale-increase 1) (cg-gaps--redisplay)) +(defun cg-gaps-zoom-out () + "Shrink the cards." (interactive) (text-scale-decrease 1) (cg-gaps--redisplay)) +(defun cg-gaps-zoom-reset () + "Reset the card size." (interactive) (text-scale-set 0) (cg-gaps--redisplay)) + +(defun cg-gaps-redraw () + "Redraw the board (e.g. after a theme or frame change)." + (interactive) + (cg-gaps--redisplay)) + + +;;;; Frameless full-SVG UI (opt-in; see `cg-gaps-svg-ui') + +(defconst cg-gaps--ui-w 820 "Default full-SVG gaps canvas width.") +(defconst cg-gaps--ui-h 380 "Default full-SVG gaps canvas height.") + +(defvar-local cg-gaps--regions nil + "Plist of clickable regions for the full-SVG gaps UI.") +(defvar-local cg-gaps--ui-last-size nil + "Last window pixel size used to render the full-SVG gaps UI.") + +(defun cg-gaps--in-rect (px py rect) + "Return non-nil when PX,PY lie inside RECT (X Y W H)." + (and rect (>= px (nth 0 rect)) (< px (+ (nth 0 rect) (nth 2 rect))) + (>= py (nth 1 rect)) (< py (+ (nth 1 rect) (nth 3 rect))))) + +(defun cg-gaps--ui-text (svg str x y size color &optional bold anchor) + "Draw text STR on SVG at X,Y (SIZE, COLOR); ANCHOR defaults to start." + (let ((a (list :x (round x) :y (round y) :font-size (round size) + :fill color :text-anchor (or anchor "start") + :font-family cg-svg-font-family))) + (when bold (setq a (append a (list :font-weight "bold")))) + (apply #'svg-text svg str a))) + +(defun cg-gaps--ui-label (svg str x y size) + "Draw an all-caps, letter-spaced section label on SVG." + (svg-text svg (upcase str) :x (round x) :y (round y) :font-size (round size) + :fill "#8fc79b" :text-anchor "start" :font-family cg-svg-font-family + :font-weight "bold" :letter-spacing "2")) + +(defun cg-gaps--ui-divider (svg x1 x2 y) + "Draw a faint horizontal divider on SVG." + (svg-line svg x1 y x2 y :stroke "#1b6b35" :stroke-width 1)) + +(defun cg-gaps--draw-panel (svg game h lpw fs) + "Draw the left status/controls panel (width LPW, scale FS). +Return a plist of clickable control regions." + (let* ((regions nil) + (F (lambda (n) (round (* n fs)))) + (px0 (funcall F 14)) (pxr (- lpw (funcall F 12))) + (dl (funcall F 8)) (dr (- lpw (funcall F 8))) + (cxp (/ lpw 2)) (y 0)) + (svg-rectangle svg 6 6 (- lpw 8) (- h 12) :rx 10 :fill "#0d4a22" :fill-opacity 0.9 + :stroke "#0a3a1a" :stroke-width 1) + (setq y (funcall F 30)) + (cg-svg--text svg (cg-gaps--vname game) cxp y (funcall F 15) "#f1c40f" t) + (setq y (+ y (funcall F 14))) (cg-gaps--ui-divider svg dl dr y) + ;; stats + (setq y (+ y (funcall F 22))) + (cg-gaps--ui-text svg "Moves" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (cg-get game :moves)) :x pxr :y y + :font-size (funcall F 14) :fill "#eaffea" :text-anchor "end" + :font-family cg-svg-font-family :font-weight "bold") + (setq y (+ y (funcall F 20))) + (cg-gaps--ui-text svg "Redeals left" px0 y (funcall F 13) "#eaffea") + (svg-text svg (number-to-string (cg-get game :redeals)) :x pxr :y y + :font-size (funcall F 14) :fill "#eaffea" :text-anchor "end" + :font-family cg-svg-font-family :font-weight "bold") + (setq y (+ y (funcall F 16))) (cg-gaps--ui-divider svg dl dr y) + ;; rules + (setq y (+ y (funcall F 20))) + (cg-gaps--ui-label svg "Rules" px0 (- y (funcall F 6)) (funcall F 10)) + (setq y (+ y (funcall F 16))) + (cg-gaps--ui-text svg (format "Head: %s" + (aref cg-gaps-rank-names (cg-gaps--head game))) + px0 y (funcall F 12) "#cfeccf") + (setq y (+ y (funcall F 16))) + (cg-gaps--ui-text svg (if (> (cg-gaps--step game) 0) "Build up 2..K" + "Build down K..2") + px0 y (funcall F 12) "#cfeccf") + (setq y (+ y (funcall F 16)) ) + (cg-gaps--ui-text svg "One suit per row" px0 y (funcall F 12) "#9fd0a8") + (setq y (+ y (funcall F 14))) (cg-gaps--ui-divider svg dl dr y) + ;; controls: the key shown on each button is the keyboard shortcut + (setq y (+ y (funcall F 20))) + (let* ((bw (- lpw px0 (funcall F 12))) (bh (funcall F 26)) (bg (funcall F 8)) + (canredeal (> (cg-get game :redeals) 0)) + (canundo (and (cg-get game :history) t)) + (defs (list (list :redeal "R" "Redeal" canredeal) + (list :undo "U" "Undo" canundo) + (list :new "N" "New" t) + (list :help "?" "Help" t)))) + (dolist (d defs) + (let* ((key (nth 0 d)) (kc (nth 1 d)) (word (nth 2 d)) (on (nth 3 d)) + (rect (list px0 y bw bh))) + (svg-rectangle svg px0 y bw bh :rx 6 + :fill (if on "#14401f" "#0e2a15") + :fill-opacity (if on 0.9 0.5) + :stroke "#0a3a1a" :stroke-width 1) + (cg-gaps--ui-text svg kc (+ px0 (funcall F 10)) (+ y (round (* bh 0.68))) + (funcall F 13) (if on "#f1c40f" "#5f7f68") t) + (cg-gaps--ui-text svg word (+ px0 (funcall F 30)) (+ y (round (* bh 0.68))) + (funcall F 13) (if on "#eaffea" "#5f7f68")) + (setq regions (plist-put regions key rect)) + (setq y (+ y bh bg))))) + ;; status message, wrapped to the panel + (let ((msg (cg-get game :message))) + (when (and msg (> (length msg) 0)) + (let ((m (if (> (length msg) (max 18 (round (/ (- lpw px0 (funcall F 12)) + (* 0.55 (funcall F 11)))))) + (substring msg 0 (max 18 (round (/ (- lpw px0 (funcall F 12)) + (* 0.55 (funcall F 11)))))) + msg))) + (cg-gaps--ui-text svg m px0 (- h (funcall F 14)) (funcall F 11) "#9fd0a8")))) + regions)) + +(defun cg-gaps--ui-svg (game &optional w h) + "Return (SVG . REGIONS) for the full-buffer gaps UI of GAME (W by H). +The board scales to fill the area beside a proportional left panel." + (let* ((W (or w cg-gaps--ui-w)) (H (or h cg-gaps--ui-h)) + (svg (svg-create W H)) (regions nil) + (fs (max 1.0 (min 2.2 (/ (+ (/ (float W) cg-gaps--ui-w) + (/ (float H) cg-gaps--ui-h)) 2.0)))) + (pscale (max 1.0 (min 1.7 (/ (float W) cg-gaps--ui-w)))) + (lpw (round (* 190 pscale))) + (bx (+ lpw 14)) (by 10) + (aw (- W bx 14)) (ah (- H by 10)) + (board (cg-get game :board)) + (cur (cg-get game :cursor)) (cr (car cur)) (cc (cdr cur)) + (hints (cg-gaps--hints game)) + (g (max 4 (round (* 6 fs)))) + (cww (/ (- aw (* 12 g)) 13)) + (chh (/ (- ah (* 3 g)) 4)) + (aspect (/ 64.0 46.0)) + (cw (max 18 (min cww (round (/ chh aspect))))) + (ch (round (* cw aspect))) + (bw (+ (* 13 cw) (* 12 g))) + (bh (+ (* 4 ch) (* 3 g))) + (x0 (+ bx (max 0 (/ (- aw bw) 2)))) + (y0 (+ by (max 0 (/ (- ah bh) 2))))) + ;; felt background + play-area panel + (svg-gradient svg "cg-gfelt" 'radial '((0 . "#1a7a38") (100 . "#0c4720"))) + (svg-rectangle svg 0 0 W H :rx 14 :gradient "cg-gfelt") + (svg-rectangle svg (- bx 6) by (+ aw 12) ah :rx 12 + :fill "#000000" :fill-opacity 0.10 + :stroke "#0e5226" :stroke-width 2) + ;; board + (let ((cg-svg-card-width cw) (cg-svg-card-height ch)) + (dotimes (r 4) + (dotimes (c 13) + (let* ((cell (cg-gaps--cell board r c)) + (spec (and cell (cons (aref cg-gaps-ranks (cdr cell)) (car cell)))) + (x (+ x0 (* c (+ cw g)))) (y (+ y0 (* r (+ ch g)))) + (hl (and (= r cr) (= c cc))) + (hint (and (null cell) (member (cons r c) hints) t))) + (cg-svg--draw-spec svg x y spec hl hint))))) + (setq regions (plist-put regions :board (list x0 y0 cw ch g))) + (setq regions (append regions (cg-gaps--draw-panel svg game H lpw fs))) + (cons svg regions))) + +(defun cg-gaps--ui-cell (px py geom) + "Map pixel PX,PY to a (ROW . COL) given board GEOM (X0 Y0 CW CH G), or nil." + (when geom + (let ((x0 (nth 0 geom)) (y0 (nth 1 geom)) (cw (nth 2 geom)) + (ch (nth 3 geom)) (g (nth 4 geom))) + (when (and (>= px x0) (>= py y0)) + (let* ((col (/ (- px x0) (+ cw g))) (row (/ (- py y0) (+ ch g))) + (xin (- px x0 (* col (+ cw g)))) (yin (- py y0 (* row (+ ch g))))) + (when (and (< col 13) (< row 4) (<= xin cw) (<= yin ch)) + (cons row col))))))) + +(defun cg-gaps--svg-ui-click (start) + "Dispatch a click at posn START within the full-SVG gaps UI." + (let* ((xy (posn-object-x-y start)) (s (cg-scale)) + (px (round (/ (car xy) s))) (py (round (/ (cdr xy) s))) + (game cg-gaps--game) (rg cg-gaps--regions)) + (cond + ((cg-gaps--in-rect px py (plist-get rg :redeal)) (cg-gaps-redeal)) + ((cg-gaps--in-rect px py (plist-get rg :undo)) (cg-gaps-undo)) + ((cg-gaps--in-rect px py (plist-get rg :new)) (cg-gaps-new)) + ((cg-gaps--in-rect px py (plist-get rg :help)) (cg-gaps-help)) + (t (let ((cell (cg-gaps--ui-cell px py (plist-get rg :board)))) + (when cell (cg-put game :cursor cell) (cg-gaps-fill))))))) + +(defun cg-gaps--insert-svg-ui (game) + "Insert the full-buffer SVG gaps UI for GAME and record its regions." + (let* ((win (get-buffer-window (current-buffer))) + (fill (and cg-gaps-svg-fill win)) + (w (if fill (max 640 (window-body-width win t)) cg-gaps--ui-w)) + (h (if fill (max 320 (- (window-body-height win t) 4)) cg-gaps--ui-h)) + (sr (cg-gaps--ui-svg game w h))) + (when fill (setq cg-gaps--ui-last-size (cons (window-body-width win t) + (window-body-height win t)))) + (setq cg-gaps--regions (cdr sr)) + (insert-image (cg-svg-image (car sr) (if fill 1.0 (cg-scale)))))) + +(defun cg-gaps--fit (&rest _) + "Re-render the full-SVG gaps UI to fit the window after a config change." + (when (and cg-gaps--game cg-gaps-svg-ui cg-gaps-svg-fill + (eq major-mode 'cg-gaps-mode)) + (let ((win (get-buffer-window (current-buffer)))) + (when win + (let ((sz (cons (window-body-width win t) (window-body-height win t)))) + (unless (equal sz cg-gaps--ui-last-size) + (setq cg-gaps--ui-last-size sz) + (cg-gaps--redisplay))))))) + +(defun cg-gaps-toggle-svg-ui () + "Toggle the full-buffer SVG board for the gaps games." + (interactive) + (setq cg-gaps-svg-ui (not cg-gaps-svg-ui)) + (setq cg-gaps--ui-last-size nil) + (cg-gaps--redisplay) + (message "Full-SVG board %s" (if cg-gaps-svg-ui "enabled" "disabled"))) + +(defvar cg-gaps-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "") #'cg-gaps-left) + (define-key map (kbd "") #'cg-gaps-right) + (define-key map (kbd "") #'cg-gaps-up) + (define-key map (kbd "") #'cg-gaps-down) + (define-key map (kbd "RET") #'cg-gaps-fill) + (define-key map "g" #'cg-gaps-redraw) + (define-key map "r" #'cg-gaps-redeal) + (define-key map "u" #'cg-gaps-undo) + (define-key map "n" #'cg-gaps-new) + (define-key map "?" #'cg-gaps-help) + (define-key map "+" #'cg-gaps-zoom-in) + (define-key map "=" #'cg-gaps-zoom-in) + (define-key map "-" #'cg-gaps-zoom-out) + (define-key map "0" #'cg-gaps-zoom-reset) + (define-key map "v" #'cg-gaps-toggle-svg-ui) + (define-key map [mouse-1] #'cg-gaps-mouse) + map) + "Keymap for `cg-gaps-mode' (Emacs style; see `cg-keys').") + +(defun cg-gaps--classic-keymap () + "Return a copy of `cg-gaps-mode-map' with vi-style hjkl and SPC added." + (let ((map (copy-keymap cg-gaps-mode-map))) + (define-key map "h" #'cg-gaps-left) + (define-key map "l" #'cg-gaps-right) + (define-key map "k" #'cg-gaps-up) + (define-key map "j" #'cg-gaps-down) + (define-key map (kbd "SPC") #'cg-gaps-fill) + map)) + +(define-derived-mode cg-gaps-mode special-mode "Gaps" + "Major mode for playing the gaps family of solitaires." + (setq-local cursor-type 'box) + (setq-local truncate-lines t) + (add-hook 'window-configuration-change-hook #'cg-gaps--fit nil t) + (when (eq cg-keys 'classic) + (use-local-map (cg-gaps--classic-keymap)))) + +(defun cg-gaps--play (class) + "Start a gaps-style game of CLASS in its own buffer." + (let* ((game (cg-gaps--deal (make-instance class))) + (buf (get-buffer-create (format "*%s*" (cg-gaps--vname game))))) + (with-current-buffer buf + (cg-gaps-mode) + (setq cg-gaps--game game) + (cg-gaps--redisplay)) + (switch-to-buffer buf))) + +;;;###autoload +(defun cg-montana () + "Play Gaps / Montana solitaire (Two at the head, build up 2..K)." + (interactive) + (cg-gaps--play 'cg-montana-game)) + +;;;###autoload +(defun cg-hells-half-acre () + "Play Hell's Half-Acre solitaire (King at the head, build down K..2)." + (interactive) + (cg-gaps--play 'cg-acre-game)) + +;;;###autoload +(defalias 'cg-gaps #'cg-montana + "Alias for `cg-montana'.") + +(provide 'cg-gaps) +;;; cg-gaps.el ends here diff --git a/cg-svg.el b/cg-svg.el new file mode 100644 index 0000000..4f7b5c4 --- /dev/null +++ b/cg-svg.el @@ -0,0 +1,381 @@ +;;; cg-svg.el --- SVG card drawing for card games -*- lexical-binding: t; -*- + +;; Copyright (C) 2026 Corwin Brust + +;; Author: Corwin Brust +;; Maintainer: Corwin Brust +;; Version: 1.0.50 +;; Package-Requires: ((emacs "26.1")) +;; Keywords: games +;; URL: https://github.com/corwin/card-games + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see . + +;;; Commentary: + +;; Reusable SVG drawing for the graphical (GUI) renderers, shared by the +;; games in this package. Console rendering remains the baseline; these +;; helpers add a prettier display when `display-graphic-p' is non-nil. +;; +;; Faces are drawn the way real cards are: a stacked rank/suit index in +;; the top-left corner (mirrored, upside-down, in the bottom-right), +;; canonical pip layouts for the number cards (with the lower pips +;; rotated 180 degrees), a large central pip for the ace, framed letters +;; for the court cards, and a distinct joker. Backs show a dotted +;; medallion; cards cast a soft shadow; the cursor card gets a glowing +;; ring. +;; +;; The primitives are game-agnostic. A card to draw is a "spec": +;; +;; (RANK-STRING . SUIT) face-up; SUIT is 0-3 or the symbol `joker'; +;; RANK-STRING is the caller's label ("A" "10" +;; "K" ...). +;; `down' a face-down card. +;; nil an empty slot / gap. +;; +;; `cg-svg-cards-svg' lays specs out in a row; `cg-svg-grid-svg' lays +;; rows out as a grid. Both return an svg object; wrap with +;; `cg-svg-image' to insert or `cg-svg-to-string' to serialize. + +;;; Code: + +(require 'svg) +(require 'cg-core) + +(defgroup cg-svg nil + "SVG rendering for card games." + :group 'card-games + :prefix "cg-svg-") + +(defcustom cg-svg-card-width 56 + "Card width in pixels." + :type 'integer :group 'cg-svg) + +(defcustom cg-svg-card-height 80 + "Card height in pixels." + :type 'integer :group 'cg-svg) + +(defcustom cg-svg-card-gap 8 + "Pixels between adjacent cards." + :type 'integer :group 'cg-svg) + +(defcustom cg-svg-card-shadow t + "When non-nil, draw a soft drop shadow under each card." + :type 'boolean :group 'cg-svg) + +(defcustom cg-svg-font-family "Helvetica, Arial, sans-serif" + "Font family used for ranks, pips and indices." + :type 'string :group 'cg-svg) + +(defcustom cg-svg-theme-colors t + "When non-nil, derive the highlight ring and card back from the +active Emacs theme (with the colour variables below as fallbacks)." + :type 'boolean :group 'cg-svg) + +(defcustom cg-svg-card-back 'dots + "Pattern drawn on a face-down card back." + :type '(choice (const dots) (const rings) (const solid)) :group 'cg-svg) + +(defcustom cg-svg-four-color nil + "When non-nil use a four-colour deck: clubs green, diamonds blue-purple +\(spades stay black, hearts red)." + :type 'boolean :group 'cg-svg) + +(defconst cg-svg-corner-radius 6 + "Corner radius of a drawn card.") + +(defvar cg-svg-red-color "#c0392b" "Colour for red suits.") +(defvar cg-svg-black-color "#2c3e50" "Colour for black suits.") +(defvar cg-svg-club-color "#1a8a3c" "Clubs colour in a four-colour deck.") +(defvar cg-svg-diamond-color "#3b3fb0" "Diamonds colour in a four-colour deck.") +(defvar cg-svg-joker-color "#8e44ad" "Colour for the Joker.") +(defvar cg-svg-face-color "#fdfdfb" "Card face fill.") +(defvar cg-svg-court-color "#f6f2e8" "Court-card inner panel fill.") +(defvar cg-svg-border-color "#566573" "Card border colour.") +(defvar cg-svg-back-color "#27496d" "Card back fill.") +(defvar cg-svg-back-trim "#9fb3cf" "Card back inner trim/dots.") +(defvar cg-svg-highlight-color "#f1c40f" "Cursor/selection highlight.") +(defvar cg-svg-gap-color "#95a5a6" "Empty-slot outline colour.") + +(defun cg-svg--highlight () + "Resolve the cursor/selection ring colour (theme-aware)." + (if cg-svg-theme-colors + (cg-color 'region :background cg-svg-highlight-color) + cg-svg-highlight-color)) + +(defun cg-svg--back-fill () + "Resolve the card-back fill colour (theme-aware)." + (if cg-svg-theme-colors + (cg-color 'mode-line :background cg-svg-back-color) + cg-svg-back-color)) + +(defun cg-svg--court-fill (suit) + "Return a faint suit-tinted fill for a court card of SUIT." + (cond ((eq suit 'joker) "#f3eafa") + ((cg-red-suit-p suit) "#fbeceb") + (t "#eef2f6"))) + +(defvar cg-svg-hint-color "#27ae60" "Colour ringing a valid move target.") + +(defun cg-svg--hint () + "Resolve the valid-move hint colour (theme-aware)." + (if cg-svg-theme-colors + (cg-color 'success :foreground cg-svg-hint-color) + cg-svg-hint-color)) + +(defconst cg-svg--pip-layout + '((1 (0.5 . 0.50)) + (2 (0.5 . 0.16) (0.5 . 0.84)) + (3 (0.5 . 0.16) (0.5 . 0.50) (0.5 . 0.84)) + (4 (0.30 . 0.16) (0.70 . 0.16) (0.30 . 0.84) (0.70 . 0.84)) + (5 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.50) (0.30 . 0.84) (0.70 . 0.84)) + (6 (0.30 . 0.16) (0.70 . 0.16) (0.30 . 0.50) (0.70 . 0.50) + (0.30 . 0.84) (0.70 . 0.84)) + (7 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.33) (0.30 . 0.50) (0.70 . 0.50) + (0.30 . 0.84) (0.70 . 0.84)) + (8 (0.30 . 0.16) (0.70 . 0.16) (0.5 . 0.33) (0.30 . 0.50) (0.70 . 0.50) + (0.5 . 0.67) (0.30 . 0.84) (0.70 . 0.84)) + (9 (0.30 . 0.14) (0.70 . 0.14) (0.30 . 0.38) (0.70 . 0.38) (0.5 . 0.50) + (0.30 . 0.62) (0.70 . 0.62) (0.30 . 0.86) (0.70 . 0.86)) + (10 (0.30 . 0.14) (0.70 . 0.14) (0.5 . 0.26) (0.30 . 0.38) (0.70 . 0.38) + (0.30 . 0.62) (0.70 . 0.62) (0.5 . 0.74) (0.30 . 0.86) (0.70 . 0.86))) + "Canonical pip positions per rank (fractions of the inner card area). +Pips with a Y fraction above 0.5 are drawn rotated 180 degrees.") + +(defun cg-svg--suit-color (suit) + "Return the ink colour for SUIT (0-3 or the symbol `joker')." + (cond ((eq suit 'joker) cg-svg-joker-color) + (cg-svg-four-color + (pcase suit (0 cg-svg-black-color) (1 cg-svg-club-color) + (2 cg-svg-diamond-color) (3 cg-svg-red-color) + (_ cg-svg-black-color))) + ((cg-red-suit-p suit) cg-svg-red-color) + (t cg-svg-black-color))) + +(defun cg-svg--suit-glyph (suit) + "Return the glyph for SUIT (0-3 or the symbol `joker')." + (if (eq suit 'joker) "★" (aref cg-suits suit))) + +(defun cg-svg--text (svg str x y size color &optional bold transform) + "Add centred text STR to SVG at X, Y with SIZE, COLOR, BOLD, TRANSFORM." + (let ((args (list :x (round x) :y (round y) :font-size (round size) + :fill color :text-anchor "middle" + :font-family cg-svg-font-family))) + (when bold (setq args (append args (list :font-weight "bold")))) + (when transform (setq args (append args (list :transform transform)))) + (apply #'svg-text svg str args))) + +(defun cg-svg--index (svg x y w h rank glyph color flip) + "Draw a stacked RANK/GLYPH index in COLOR on SVG. +Top-left normally; bottom-right and upside-down when FLIP is non-nil." + (let* ((rs (max 8 (round (* h 0.18)))) + (gs (max 7 (round (* h 0.15)))) + (ix (+ x (round (* w 0.16)))) + (ry (+ y (round (* h 0.18)))) + (gy (+ ry (round (* gs 1.05)))) + (tr (and flip (format "rotate(180 %d %d)" + (round (+ x (/ w 2.0))) + (round (+ y (/ h 2.0))))))) + (when (and rank (> (length rank) 0)) + (cg-svg--text svg rank ix ry rs color t tr)) + (cg-svg--text svg glyph ix gy gs color nil tr))) + +(defun cg-svg--pip (svg px py size glyph color flip) + "Draw a single pip GLYPH of SIZE in COLOR centred at PX, PY on SVG." + (cg-svg--text svg glyph px (+ py (* size 0.36)) size color nil + (and flip (format "rotate(180 %d %d)" (round px) (round py))))) + +(defun cg-svg--draw-pips (svg x y w h n glyph color) + "Lay out N pips of GLYPH in COLOR within the card at X, Y (W by H) on SVG." + (let* ((mx (* w 0.24)) (my (* h 0.14)) + (iw (- w (* 2 mx))) (ih (- h (* 2 my))) + (ps (max 9 (round (* h 0.155)))) + (layout (cdr (assq n cg-svg--pip-layout)))) + (dolist (pos layout) + (cg-svg--pip svg (+ x mx (* (car pos) iw)) (+ y my (* (cdr pos) ih)) + ps glyph color (> (cdr pos) 0.5))))) + +(defun cg-svg--draw-ace (svg x y w h glyph color) + "Draw a single large central pip (an ace) in COLOR on SVG." + (cg-svg--pip svg (+ x (/ w 2.0)) (+ y (/ h 2.0)) (round (* h 0.42)) + glyph color nil)) + +(defun cg-svg--draw-court (svg x y w h rank glyph color suit) + "Draw a framed court card (RANK letter + GLYPH) of SUIT in COLOR on SVG. +The inner panel has a quarter-circle scallop cut into each corner; the +scallop radius is 8.5% of the panel height (17% diameter)." + (let* ((mx (round (* w 0.15))) (my (round (* h 0.16))) + (bx (+ x mx)) (by (+ y my)) + (bw (- w (* 2 mx))) (bh (- h (* 2 my))) + (rr (max 1 (round (* bh 0.085)))) + (d (format (concat "M %d %d L %d %d " + "A %d %d 0 0 0 %d %d L %d %d " + "A %d %d 0 0 0 %d %d L %d %d " + "A %d %d 0 0 0 %d %d L %d %d " + "A %d %d 0 0 0 %d %d Z") + (+ bx rr) by (- (+ bx bw) rr) by + rr rr (+ bx bw) (+ by rr) + (+ bx bw) (- (+ by bh) rr) + rr rr (- (+ bx bw) rr) (+ by bh) + (+ bx rr) (+ by bh) + rr rr bx (- (+ by bh) rr) + bx (+ by rr) + rr rr (+ bx rr) by))) + (svg-node svg 'path :d d :fill (cg-svg--court-fill suit) + :stroke color :stroke-width 1) + (cg-svg--text svg rank (+ x (/ w 2.0)) (+ y (* h 0.54)) (* h 0.34) color t) + (cg-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.76)) (* h 0.20) color))) + +(defun cg-svg--draw-joker (svg x y w h color) + "Draw the joker face in COLOR on SVG." + (cg-svg--text svg "★" (+ x (/ w 2.0)) (+ y (* h 0.52)) (* h 0.40) color) + (cg-svg--text svg "JOKER" (+ x (/ w 2.0)) (+ y (* h 0.74)) (* h 0.135) color t)) + +(defun cg-svg--draw-back (svg x y w h r) + "Draw a face-down card back on SVG at X, Y (W by H, corner R). +The pattern is controlled by `cg-svg-card-back'." + (svg-rectangle svg x y w h :rx r :ry r :fill (cg-svg--back-fill) + :stroke cg-svg-border-color :stroke-width 1) + (svg-rectangle svg (+ x 4) (+ y 4) (- w 8) (- h 8) :rx 4 :fill "none" + :stroke cg-svg-back-trim :stroke-width 1) + (pcase cg-svg-card-back + ('solid nil) + ('rings + (svg-rectangle svg (+ x 8) (+ y 8) (- w 16) (- h 16) :rx 5 :fill "none" + :stroke cg-svg-back-trim :stroke-width 1) + (svg-rectangle svg (+ x 12) (+ y 12) (- w 24) (- h 24) :rx 4 :fill "none" + :stroke cg-svg-back-trim :stroke-width 1)) + (_ + (let ((gy (+ y 10))) + (while (< gy (- (+ y h) 8)) + (let ((gx (+ x 10))) + (while (< gx (- (+ x w) 8)) + (svg-circle svg gx gy 1.1 :fill cg-svg-back-trim) + (setq gx (+ gx 9)))) + (setq gy (+ gy 9))))))) + +(defun cg-svg--draw-face (svg x y w h r rank suit) + "Draw a face-up card (RANK of SUIT) on SVG at X, Y (W by H, corner R)." + (svg-rectangle svg x y w h :rx r :ry r :fill cg-svg-face-color + :stroke cg-svg-border-color :stroke-width 1) + (let ((color (cg-svg--suit-color suit)) + (glyph (cg-svg--suit-glyph suit))) + (cg-svg--index svg x y w h rank glyph color nil) + (cg-svg--index svg x y w h rank glyph color t) + (cond + ((eq suit 'joker) (cg-svg--draw-joker svg x y w h color)) + ((member rank '("J" "Q" "K")) (cg-svg--draw-court svg x y w h rank glyph color suit)) + ((equal rank "A") (cg-svg--draw-ace svg x y w h glyph color)) + (t (let ((n (truncate (string-to-number (or rank "0"))))) + (if (and (>= n 1) (<= n 10)) + (cg-svg--draw-pips svg x y w h n glyph color) + (cg-svg--text svg glyph (+ x (/ w 2.0)) (+ y (* h 0.6)) + (* h 0.40) color))))))) + +(cl-defun cg-svg-card (svg x y &key rank suit down gap highlight hint) + "Draw one card onto SVG with its top-left corner at X, Y. +With GAP draw an empty slot; with DOWN draw a face-down card; +otherwise draw a face card labelled RANK of SUIT (0-3 or `joker'). +HIGHLIGHT draws a glowing cursor ring around the card." + (let* ((w cg-svg-card-width) + (h cg-svg-card-height) + (r cg-svg-corner-radius)) + (when (and cg-svg-card-shadow (not gap)) + (svg-rectangle svg (+ x 2) (+ y 3) w h :rx r :ry r + :fill "black" :fill-opacity 0.16)) + (cond + (gap + (svg-rectangle svg x y w h :rx r :ry r :fill "black" :fill-opacity 0.05 + :stroke cg-svg-gap-color :stroke-width 1.5 + :stroke-dasharray "4,4")) + (down (cg-svg--draw-back svg x y w h r)) + (t (cg-svg--draw-face svg x y w h r rank suit))) + (when hint + (svg-rectangle svg (- x 2) (- y 2) (+ w 4) (+ h 4) :rx (+ r 1) + :fill "none" :stroke (cg-svg--hint) :stroke-width 2 + :stroke-dasharray "3,3")) + (when highlight + (let ((hl (cg-svg--highlight))) + (svg-rectangle svg (- x 4) (- y 4) (+ w 8) (+ h 8) :rx (+ r 3) + :fill "none" :stroke hl :stroke-opacity 0.45 :stroke-width 6) + (svg-rectangle svg (- x 3) (- y 3) (+ w 6) (+ h 6) :rx (+ r 2) + :fill "none" :stroke hl :stroke-width 2.5))))) + +(defun cg-svg--draw-spec (svg x y spec highlight &optional hint) + "Draw SPEC onto SVG at X, Y, with HIGHLIGHT and optional HINT ring. +SPEC is (RANK . SUIT), the symbol `down', or nil for a gap." + (cond + ((null spec) (cg-svg-card svg x y :gap t :highlight highlight :hint hint)) + ((eq spec 'down) (cg-svg-card svg x y :down t :highlight highlight :hint hint)) + (t (cg-svg-card svg x y :rank (car spec) :suit (cdr spec) + :highlight highlight :hint hint)))) + +(cl-defun cg-svg-cards-svg (specs &key highlight (pad 10) (overlap 0)) + "Return an svg object drawing SPECS left to right. +SPECS is a list of card specs (see Commentary). HIGHLIGHT is the +index of a card to ring. OVERLAP fans cards by overlapping them by +that many pixels. PAD is the margin around the row." + (let* ((w cg-svg-card-width) + (h cg-svg-card-height) + (step (max 1 (- (+ w cg-svg-card-gap) overlap))) + (n (length specs)) + (width (+ (* 2 pad) (if (> n 0) (+ (* (1- n) step) w) w))) + (height (+ (* 2 pad) h)) + (svg (svg-create width height))) + (let ((x pad) (i 0)) + (dolist (spec specs) + (cg-svg--draw-spec svg x pad spec (and highlight (= i highlight))) + (setq x (+ x step) i (1+ i)))) + svg)) + +(cl-defun cg-svg-grid-svg (rows &key cursor hints (pad 10)) + "Return an svg object drawing ROWS as a grid of cards. +ROWS is a list of rows, each a list of card specs. CURSOR is (ROW . COL) +to highlight, or nil. HINTS is a list of (ROW . COL) to ring as valid +targets. PAD is the margin around the grid." + (let* ((w cg-svg-card-width) + (h cg-svg-card-height) + (gx cg-svg-card-gap) + (gy cg-svg-card-gap) + (ncols (apply #'max 1 (mapcar #'length rows))) + (nrows (max 1 (length rows))) + (width (+ (* 2 pad) (* ncols w) (* (1- ncols) gx))) + (height (+ (* 2 pad) (* nrows h) (* (1- nrows) gy))) + (svg (svg-create width height)) + (r 0)) + (dolist (row rows) + (let ((c 0) + (y (+ pad (* r (+ h gy))))) + (dolist (spec row) + (cg-svg--draw-spec svg (+ pad (* c (+ w gx))) y spec + (and cursor (= r (car cursor)) (= c (cdr cursor))) + (and hints (member (cons r c) hints) t)) + (setq c (1+ c)))) + (setq r (1+ r))) + svg)) + +(defun cg-svg-image (svg &optional scale) + "Return an Emacs image for SVG, optionally enlarged by SCALE." + (if (and scale (/= scale 1.0)) + (svg-image svg :scale scale) + (svg-image svg))) + +(defun cg-svg-to-string (svg) + "Return the serialized XML string for SVG." + (with-temp-buffer + (svg-print svg) + (buffer-string))) + +(provide 'cg-svg) +;;; cg-svg.el ends here diff --git a/test/card-games-tests.el b/test/card-games-tests.el new file mode 100644 index 0000000..97fb037 --- /dev/null +++ b/test/card-games-tests.el @@ -0,0 +1,216 @@ +;;; card-games-tests.el --- ERT tests for card-games -*- lexical-binding: t; -*- + +;; Run with: make test (or) +;; emacs -Q --batch -L . -L test -l test/card-games-tests.el \ +;; -f ert-run-tests-batch-and-exit + +;;; Code: + +(require 'ert) +(require 'cl-lib) +(require 'card-games) + +;;;; cg-core + +(ert-deftest cgt-core-color-fallback () + (should (equal "#123456" (cg-color 'no-such-face-xyzzy :background "#123456")))) + +;;;; Gaps + +(ert-deftest cgt-gaps-deal () + (let* ((g (cg-gaps--deal (make-instance 'cg-montana-game))) + (b (cg-get g :board)) (cards 0) (gaps 0)) + (dotimes (r 4) (dotimes (c 13) + (if (cg-gaps--cell b r c) (cl-incf cards) (cl-incf gaps)))) + (should (= cards 48)) (should (= gaps 4)))) + +(ert-deftest cgt-gaps-win () + (let ((g (make-instance 'cg-montana-game)) (b (make-vector 4 nil))) + (dotimes (r 4) + (let ((row (make-vector 13 nil))) + (dotimes (c 12) (aset row c (cons r c))) + (aset b r row))) + (cg-put g :board b) + (should (cg-won-p g)))) + +(ert-deftest cgt-acre-win () + ;; King-head descending: row r col c == (suit r . (- 11 c)), gap at col 12 + (let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil))) + (dotimes (r 4) + (let ((row (make-vector 13 nil))) + (dotimes (c 12) (aset row c (cons r (- 11 c)))) + (aset b r row))) + (cg-put g :board b) + (should (cg-won-p g)) + ;; head gap wants a King; right of a Two is dead + (should (eq 'head (cg-gaps--needed g b 0 0))))) + +(ert-deftest cgt-acre-needed () + (let ((g (make-instance 'cg-acre-game)) (b (make-vector 4 nil))) + (dotimes (r 4) (aset b r (make-vector 13 nil))) + ;; left neighbour King(11) at (0,0): gap (0,1) wants Queen(10) same suit + (aset (aref b 0) 0 (cons 0 11)) + (should (equal (cons 0 10) (cg-gaps--needed g b 0 1))) + ;; left neighbour Two(0): nothing follows -> nil (Two is the dead end) + (aset (aref b 1) 0 (cons 0 0)) + (should (null (cg-gaps--needed g b 1 1))))) + +(ert-deftest cgt-gaps-hit () + (dotimes (r 4) (dotimes (c 13) + (let ((px (+ cg-gaps--svg-pad (* c (+ cg-gaps--svg-card-w cg-gaps--svg-gap)) + (/ cg-gaps--svg-card-w 2))) + (py (+ cg-gaps--svg-pad (* r (+ cg-gaps--svg-card-h cg-gaps--svg-gap)) + (/ cg-gaps--svg-card-h 2)))) + (should (equal (cons r c) (cg-gaps--xy->cell px py))))))) + +;;;; 500 + +(ert-deftest cgt-bid-deck () (should (= 45 (length (cg-bid--full-deck))))) + +(ert-deftest cgt-bid-power () + (should (> (cg-bid-power cg-bid-joker 0 0) (cg-bid-power '(0 . 7) 0 0))) + (should (> (cg-bid-power '(0 . 7) 0 0) (cg-bid-power '(1 . 7) 0 0))) + (should (< (cg-bid-power '(2 . 10) 0 3) 100))) + +(ert-deftest cgt-bid-trick () + (should (= 2 (cg-bid-trick-winner + '((0 . (3 . 10)) (1 . (3 . 0)) (2 . (0 . 0)) (3 . (2 . 10))) 0 3)))) + +(ert-deftest cgt-bid-follow () + (should (equal '((1 . 7)) (cg-bid-legal-cards '((1 . 7) (1 . 0) (3 . 0)) 0 0)))) + +(ert-deftest cgt-bid-sort-display () + (should (cg-bid-joker-p + (car (cg-bid-sort-display (list '(3 . 10) cg-bid-joker '(0 . 7)) 0))))) + +(ert-deftest cgt-bid-south-hit () + (dolist (n '(1 5 10 15)) + (cl-destructuring-bind (x0 step y) (cg-bid--south-layout n) + (dotimes (i n) + (should (equal i (cg-bid--south-hit (+ x0 (* i step) 2) (+ y 5) n))))))) + +(ert-deftest cgt-bid-full-game () + (let ((cg-bid--human-seats nil)) + (dotimes (_ 12) + (let ((g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) + (cg-bid--run g) + (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) + (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g)) + (should (eq 'gameover (cg-get g :phase))))))) + +(ert-deftest cgt-bid-smart-beats-basic () + (let ((w0 0) (w1 0)) + (random "ert-h2h") + (dotimes (_ 50) + (let ((cg-bid--human-seats nil) + (cg-bid-ai-policies (vector 'smart 'basic 'smart 'basic)) + (g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) + (cg-bid--run g) + (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 4000)) + (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)) (cg-bid--run g)) + (pcase (cg-get g :game-over) (0 (cl-incf w0)) (1 (cl-incf w1))))) + (should (> w0 (* 1.8 w1))))) + +;;;; SVG + +(ert-deftest cgt-svg-builds () + (should (stringp (cg-svg-to-string + (cg-svg-grid-svg (list (list (cons "A" 0) (cons nil 'joker) 'down nil)))))) + (should (stringp (cg-svg-to-string + (cg-bid--table-svg (cg-bid--deal (make-instance 'cg-bid-game))))))) + +;;;; Chooser + +(ert-deftest cgt-chooser-registry () + (should (assoc "500 (Bid)" card-games-list)) + (should (commandp 'card-game))) + +(provide 'card-games-tests) +;;; card-games-tests.el ends here + +(ert-deftest cgt-ai-step () + ;; ai-step advances within a hand; the caller deals the next hand at 'done. + (let ((cg-bid--human-seats nil) + (g (cg-bid--deal (make-instance 'cg-bid-game))) (guard 0)) + (while (and (not (eq (cg-get g :phase) 'gameover)) (< (cl-incf guard) 6000)) + (unless (cg-bid--ai-step g) + (cg-bid--deal g (mod (1+ (cg-get g :dealer)) 4)))) + (should (eq 'gameover (cg-get g :phase))))) + +(ert-deftest cgt-card-back-presets () + (dolist (cg-svg-card-back '(dots rings solid)) + (should (stringp (cg-svg-to-string + (cg-svg-cards-svg (list 'down))))))) + +(ert-deftest cgt-set-theme () + (let ((inhibit-message t)) ; keep the theme banner out of test output + (card-games-set-theme 'dark) + (should (equal "#23272e" cg-bid-felt-color)) + (card-games-set-theme 'classic) + (should (equal "#15692f" cg-bid-felt-color)))) + +(ert-deftest cgt-scale () + (require 'face-remap) + (let ((text-scale-mode-amount 0)) (should (= 1.0 (cg-scale)))) + (let ((text-scale-mode-amount 2)) (should (> (cg-scale) 1.0))) + (let ((text-scale-mode-amount -2)) (should (< (cg-scale) 1.0)))) + +(ert-deftest cgt-mode-line-announce () + (let ((g (cg-bid--deal (make-instance 'cg-bid-game)))) + (should (stringp (cg-bid--mode-line g))) + (should (string-match-p "bid" (cg-bid--mode-line g))))) + +(ert-deftest cgt-gaps-mode-line () + (let ((g (cg-gaps--deal (make-instance 'cg-montana-game)))) + (should (string-match-p "moves" (cg-gaps--mode-line g))))) + +(ert-deftest cgt-keys-default () + (should (eq cg-keys 'emacs)) + (should (commandp 'cg-gaps-redraw)) + (should (commandp 'cg-bid-redraw)) + ;; g redraws (not new) + (should (eq 'cg-gaps-redraw (lookup-key cg-gaps-mode-map "g"))) + (should (eq 'cg-bid-redraw (lookup-key cg-bid-mode-map "g")))) + +(ert-deftest cgt-keys-classic () + ;; emacs map has no h/SPC binding; classic adds them + (should-not (lookup-key cg-gaps-mode-map "h")) + (should (eq 'cg-gaps-left (lookup-key (cg-gaps--classic-keymap) "h"))) + (should (eq 'cg-bid-left (lookup-key (cg-bid--classic-keymap) "h")))) + +(ert-deftest cgt-svgui-builds () + (let ((g (cg-bid--deal (make-instance 'cg-bid-game)))) + (cg-put g :phase 'auction) (cg-put g :bidder 0) + (let ((sr (cg-bid--ui-svg g))) + (should (stringp (cg-svg-to-string (car sr)))) + ;; available bids have clickable rects; a cell centre maps back to its bid + (let* ((bids (plist-get (cdr sr) :bids)) (e (car bids)) + (r (cdr e)) (cx (+ (nth 0 r) (/ (nth 2 r) 2))) (cy (+ (nth 1 r) (/ (nth 3 r) 2)))) + (should (eq (car e) (cg-bid--region-bid cx cy (cdr sr)))))))) + +(ert-deftest cgt-gaps-svgui-builds () + ;; the full-SVG gaps UI builds, and a cell centre maps back to its (row . col) + (let ((g (cg-gaps--deal (make-instance 'cg-montana-game)))) + (let* ((sr (cg-gaps--ui-svg g 820 380)) + (geom (plist-get (cdr sr) :board)) + (x0 (nth 0 geom)) (y0 (nth 1 geom)) + (cw (nth 2 geom)) (ch (nth 3 geom)) (gp (nth 4 geom))) + (should (stringp (cg-svg-to-string (car sr)))) + (should (plist-get (cdr sr) :new)) ; control regions present + (should (equal (cons 2 3) + (cg-gaps--ui-cell (+ x0 (* 3 (+ cw gp)) (/ cw 2)) + (+ y0 (* 2 (+ ch gp)) (/ ch 2)) + geom)))))) + +(ert-deftest cgt-classic-folds-controls () + ;; graphical classic UI: one action-button row, no textual key-help + (with-temp-buffer + (cg-bid-mode) + (setq cg-bid--game (cg-bid--deal (make-instance 'cg-bid-game))) + (let ((cg-bid-svg-ui nil) (inhibit-read-only t)) + (cg-bid--insert-graphical cg-bid--game) + (cg-bid--insert-buttons cg-bid--game)) + (let ((s (buffer-string))) + (should-not (string-match-p "RET\\] play card" s)) ; key-help removed + (should (string-match-p "Help" s)) ; button row present + (should-not (string-match-p "New" s))))) ; no mid-hand new deal