2026-06-23 19:34:36 -05:00
|
|
|
;;; 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"))))
|
|
|
|
|
|
2026-06-23 21:56:31 -05:00
|
|
|
(ert-deftest cgt-core-suit-glyph ()
|
|
|
|
|
(let ((cg-symbols '((0 . "S") (1 . "C") (2 . "D") (3 . "H") (joker . "JK"))))
|
|
|
|
|
(should (equal "S" (cg-suit-glyph 0)))
|
|
|
|
|
(should (equal "JK" (cg-suit-glyph 'joker))))
|
|
|
|
|
(should (equal "♠" (cg-suit-glyph 0))))
|
|
|
|
|
|
|
|
|
|
;;;; Renderer skins
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-render-registry ()
|
|
|
|
|
(should (memq 'text (cg-renderer-names)))
|
|
|
|
|
(should (memq 'svg (cg-renderer-names)))
|
|
|
|
|
(should (memq 'svg-fill (cg-renderer-names)))
|
|
|
|
|
(should (object-of-class-p (cg-make-renderer 'svg) 'cg-svg-renderer))
|
|
|
|
|
(should (object-of-class-p (cg-make-renderer 'svg-fill) 'cg-svg-renderer))
|
|
|
|
|
(should-not (cg-make-renderer 'no-such-treatment)))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-render-resolve ()
|
|
|
|
|
(should (eq 'text (cg-render-resolve-treatment 'text)))
|
|
|
|
|
(should (memq (cg-render-resolve-treatment 'auto) '(text svg))))
|
|
|
|
|
|
2026-06-23 22:24:18 -05:00
|
|
|
;;;; Networking
|
|
|
|
|
|
|
|
|
|
(defclass cgt-net-game (cg-game)
|
|
|
|
|
((env :initarg :env :initform '(:counter 0)))
|
|
|
|
|
"Throwaway game whose only move adds to a counter.")
|
|
|
|
|
|
|
|
|
|
(cl-defmethod cg-net-apply-move ((g cgt-net-game) _seat move)
|
|
|
|
|
(cg-put g :counter (+ (or (cg-get g :counter) 0) move))
|
|
|
|
|
t)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-net-loopback ()
|
|
|
|
|
"Host-authoritative move sync over a loopback TCP socket."
|
|
|
|
|
(condition-case _
|
|
|
|
|
(delete-process
|
|
|
|
|
(make-network-process :name "cgt-probe" :server t :service 0
|
|
|
|
|
:host "127.0.0.1" :family 'ipv4))
|
|
|
|
|
(error (ert-skip "TCP not available")))
|
|
|
|
|
(let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0)))
|
|
|
|
|
(srv (cg-net-host-start hgame 0))
|
|
|
|
|
(port (process-contact srv :service))
|
|
|
|
|
(cgame (make-instance 'cgt-net-game :env (list :counter 0))))
|
|
|
|
|
(unwind-protect
|
|
|
|
|
(progn
|
|
|
|
|
(cg-net-connect "127.0.0.1" port "Test" cgame)
|
|
|
|
|
(dotimes (_ 12) (accept-process-output nil 0.05))
|
|
|
|
|
(should (= 0 (cg-get cgame :counter)))
|
|
|
|
|
(cg-net-send-move 7)
|
|
|
|
|
(dotimes (_ 12) (accept-process-output nil 0.05))
|
|
|
|
|
(should (= 7 (cg-get hgame :counter)))
|
|
|
|
|
(should (= 7 (cg-get cgame :counter))))
|
|
|
|
|
(cg-net-disconnect)
|
|
|
|
|
(cg-net-host-stop))))
|
|
|
|
|
|
2026-06-23 19:34:36 -05:00
|
|
|
;;;; 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
|
2026-06-23 23:34:48 -05:00
|
|
|
|
|
|
|
|
;;;; Live 500 (networking)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bid-net-filter ()
|
|
|
|
|
"Per-seat 500 state hides others' cards and rotates the viewer South."
|
|
|
|
|
(cl-flet ((ck (h) (sort (mapcar #'prin1-to-string h) #'string<)))
|
|
|
|
|
(let* ((cg-bid--human-seats '(0 1 2 3))
|
|
|
|
|
(g (cg-bid--deal (make-instance 'cg-bid-game) 3))
|
|
|
|
|
(st (cg-net-game-state g 1))) ; West's viewpoint
|
|
|
|
|
;; West sees its own ten cards rotated to index 0
|
|
|
|
|
(should (equal (ck (aref (plist-get st :hands) 0))
|
|
|
|
|
(ck (cg-bid--hand g 1))))
|
|
|
|
|
;; opponents are face-down counts only, not the real cards
|
|
|
|
|
(should (= 10 (length (aref (plist-get st :hands) 1))))
|
|
|
|
|
(should-not (equal (ck (aref (plist-get st :hands) 1))
|
|
|
|
|
(ck (cg-bid--hand g 2))))
|
|
|
|
|
;; the kitty stays hidden
|
|
|
|
|
(should-not (plist-get st :kitty))
|
|
|
|
|
;; South (abs 0) bids first; in West's frame that is seat 3
|
|
|
|
|
(should (= 3 (plist-get st :bidder)))
|
|
|
|
|
(should (= 1 (plist-get st :you)))))) ; :you is the absolute seat
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bid-net-apply ()
|
|
|
|
|
"The host applies only legal, in-turn moves."
|
|
|
|
|
(let* ((cg-bid--human-seats '(0 1 2 3))
|
|
|
|
|
(g (cg-bid--deal (make-instance 'cg-bid-game) 3)))
|
|
|
|
|
(should-not (cg-net-apply-move g 1 '(pass))) ; not West's turn yet
|
|
|
|
|
(should (cg-net-apply-move g 0 '(pass))) ; South may pass
|
|
|
|
|
(should (aref (cg-get g :passed) 0))
|
|
|
|
|
(should-not (cg-net-apply-move g 0 '(play (0 . 0)))) ; wrong phase
|
|
|
|
|
))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bid-net-loopback ()
|
|
|
|
|
"A 500 move travels client -> host -> filtered broadcast over TCP."
|
|
|
|
|
(condition-case _
|
|
|
|
|
(delete-process
|
|
|
|
|
(make-network-process :name "cgt-probe2" :server t :service 0
|
|
|
|
|
:host "127.0.0.1" :family 'ipv4))
|
|
|
|
|
(error (ert-skip "TCP not available")))
|
|
|
|
|
(cl-flet ((pump () (dotimes (_ 16) (accept-process-output nil 0.05))))
|
|
|
|
|
(let* ((cg-bid--human-seats '(0 1))
|
|
|
|
|
(hgame (cg-bid--deal (make-instance 'cg-bid-game) 3))
|
|
|
|
|
(srv (cg-net-host-start hgame 0))
|
|
|
|
|
(port (process-contact srv :service))
|
|
|
|
|
(cgame (make-instance 'cg-bid-game)))
|
|
|
|
|
(setf (cg-net-host-next-seat cg-net--host) 1) ; reserve South for host
|
|
|
|
|
(unwind-protect
|
|
|
|
|
(progn
|
|
|
|
|
(cg-net-connect "127.0.0.1" port "P1" cgame)
|
|
|
|
|
(pump)
|
|
|
|
|
;; the client (seat 1) sees its own ten cards at index 0
|
|
|
|
|
(should (= 10 (length (aref (cg-get cgame :hands) 0))))
|
|
|
|
|
(should (equal
|
|
|
|
|
(sort (mapcar #'prin1-to-string (aref (cg-get cgame :hands) 0)) #'string<)
|
|
|
|
|
(sort (mapcar #'prin1-to-string (cg-bid--hand hgame 1)) #'string<)))
|
|
|
|
|
;; make it the client's turn, then let it pass
|
|
|
|
|
(cg-put hgame :bidder 1)
|
|
|
|
|
(cg-net-host-broadcast)
|
|
|
|
|
(pump)
|
|
|
|
|
(should (= 0 (cg-get cgame :bidder))) ; rotated: West sees itself bidding
|
|
|
|
|
(cg-net-send-move '(pass))
|
|
|
|
|
(pump)
|
|
|
|
|
(should (aref (cg-get hgame :passed) 1)))
|
|
|
|
|
(cg-net-disconnect)
|
|
|
|
|
(cg-net-host-stop)))))
|
Add 16 games and known-games research; bump to 1.0.60
Console UNICODE games on the cg-core EIEIO engine, all ERT-tested (88/88):
- Tableau solitaire (cg-solitaire.el): Klondike, FreeCell, Spider, Yukon,
Canfield, Forty Thieves, Scorpion.
- Pile solitaire (cg-patience.el): Golf, TriPeaks, Pyramid.
- Trick-taking (cg-trick.el): Hearts, Spades, Whist, Oh Hell.
- Shedding/climbing: Crazy Eights (cg-eights.el), President (cg-president.el).
Wire all into the card-game chooser, Makefile, and README; add
known-games.org research collation; bump every file to 1.0.60.
2026-06-25 01:58:24 -05:00
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;; --- New games added 2026-06-24: solitaires, trick games, Crazy Eights ---
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-deck ()
|
|
|
|
|
(should (= 52 (length (cg-sol--make-deck 1))))
|
|
|
|
|
(should (= 104 (length (cg-sol--make-deck 2)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-klondike-deal ()
|
|
|
|
|
(let* ((g (cg-sol--deal (cg-klondike-game))))
|
|
|
|
|
(should (= 7 (oref g ncols)))
|
|
|
|
|
(dotimes (c 7)
|
|
|
|
|
(should (= (1+ c) (length (cg-sol--col g c))))
|
|
|
|
|
(should (= c (cg-sol--down g c)))
|
|
|
|
|
;; top card is face up
|
|
|
|
|
(should (cg-sol--col-top g c)))
|
|
|
|
|
(should (= 24 (length (cg-get g :stock))))
|
|
|
|
|
(should (cl-every #'null (append (cg-get g :found) nil)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-freecell-deal ()
|
|
|
|
|
(let* ((g (cg-sol--deal (cg-freecell-game)))
|
|
|
|
|
(total 0))
|
|
|
|
|
(should (= 8 (oref g ncols)))
|
|
|
|
|
(dotimes (c 8) (cl-incf total (length (cg-sol--col g c)))
|
|
|
|
|
(should (= 0 (cg-sol--down g c))))
|
|
|
|
|
(should (= 52 total))
|
|
|
|
|
(should (null (cg-get g :stock)))
|
|
|
|
|
(should (= 4 (length (cg-get g :free))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-spider-deal ()
|
|
|
|
|
(let* ((g (cg-sol--deal (cg-spider-game)))
|
|
|
|
|
(total 0))
|
|
|
|
|
(should (= 10 (oref g ncols)))
|
|
|
|
|
(dotimes (c 10) (cl-incf total (length (cg-sol--col g c))))
|
|
|
|
|
(should (= 54 total))
|
|
|
|
|
(should (= 50 (length (cg-get g :stock))))
|
|
|
|
|
(dotimes (c 4) (should (= 6 (length (cg-sol--col g c)))))
|
|
|
|
|
(dotimes (k 6) (should (= 5 (length (cg-sol--col g (+ 4 k))))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-rules-alt ()
|
|
|
|
|
(let ((g (cg-klondike-game)))
|
|
|
|
|
;; red 6 onto black 7 ok; black 6 onto black 7 no
|
|
|
|
|
(should (cg-sol--place-p g '(0 . 6) '(3 . 5))) ; 7s under 6h
|
|
|
|
|
(should-not (cg-sol--place-p g '(0 . 6) '(1 . 5))) ; 6c on 7s same color
|
|
|
|
|
(should (cg-sol--empty-accepts g '(0 . 12))) ; king
|
|
|
|
|
(should-not (cg-sol--empty-accepts g '(0 . 11))))) ; queen
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-rules-spider ()
|
|
|
|
|
(let ((g (cg-spider-game)))
|
|
|
|
|
;; build down any suit
|
|
|
|
|
(should (cg-sol--place-p g '(0 . 6) '(3 . 5)))
|
|
|
|
|
(should (cg-sol--place-p g '(0 . 6) '(1 . 5)))
|
|
|
|
|
;; run cohesion requires same suit
|
|
|
|
|
(should (cg-sol--link-p g '(0 . 6) '(0 . 5)))
|
|
|
|
|
(should-not (cg-sol--link-p g '(0 . 6) '(1 . 5)))
|
|
|
|
|
(should (cg-sol--empty-accepts g '(0 . 3)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-top-run ()
|
|
|
|
|
(let ((g (cg-klondike-game)))
|
|
|
|
|
(cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(1 . 7)))) ; 9s 8d 7c
|
|
|
|
|
(cg-put g :down (vector 0))
|
|
|
|
|
;; 9s(black) 8d(red) 7c(black) is a valid alt run of 3
|
|
|
|
|
(should (= 3 (length (cg-sol--top-run g 0))))
|
|
|
|
|
;; break color: 9s 8d 7d -> only 8d 7d? 7d red on 8d red invalid -> run is just 7d
|
|
|
|
|
(cg-put g :tableau (vector (list '(0 . 9) '(2 . 8) '(2 . 7))))
|
|
|
|
|
(should (= 1 (length (cg-sol--top-run g 0))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-move-col ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-klondike-game))))
|
|
|
|
|
;; craft: col0 top = 7c(black), col1 top = 6h(red); move 6h onto 7c
|
|
|
|
|
(cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil))
|
|
|
|
|
(cg-put g :down (vector 0 0 0 0 0 0 0))
|
|
|
|
|
(let ((cards (last (cg-sol--col g 1) 1)))
|
|
|
|
|
(should (cg-sol--can-drop g '(col . 0) cards))
|
|
|
|
|
(cg-sol--take g '(col . 1) 1)
|
|
|
|
|
(cg-sol--drop g '(col . 0) cards))
|
|
|
|
|
(should (equal '((1 . 7) (3 . 6)) (cg-sol--col g 0)))
|
|
|
|
|
(should (null (cg-sol--col g 1)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-foundation-and-win ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-klondike-game))))
|
|
|
|
|
;; empty foundations: place an Ace then a 2 of same suit
|
|
|
|
|
(should (cg-sol--found-accepts g 0 '(0 . 0)))
|
|
|
|
|
(cg-sol--drop g '(found . 0) (list '(0 . 0)))
|
|
|
|
|
(should (cg-sol--found-accepts g 0 '(0 . 1)))
|
|
|
|
|
(should-not (cg-sol--found-accepts g 0 '(1 . 1)))
|
|
|
|
|
;; build a winning state: fill all four foundations A..K
|
|
|
|
|
(let ((found (make-vector 4 nil)))
|
|
|
|
|
(dotimes (s 4)
|
|
|
|
|
(aset found s (cl-loop for r below 13 collect (cons s r))))
|
|
|
|
|
(cg-put g :found found))
|
|
|
|
|
(should (cg-won-p g))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-spider-harvest ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-spider-game))))
|
|
|
|
|
;; put a complete K..A spade run as the whole of column 0
|
|
|
|
|
(cg-put g :tableau (let ((v (cg-get g :tableau)))
|
|
|
|
|
(aset v 0 (cl-loop for r from 12 downto 0 collect (cons 0 r)))
|
|
|
|
|
v))
|
|
|
|
|
(cg-put g :down (let ((v (cg-get g :down))) (aset v 0 0) v))
|
|
|
|
|
(cg-put g :sets 0)
|
|
|
|
|
(cg-sol--harvest g)
|
|
|
|
|
(should (= 1 (cg-get g :sets)))
|
|
|
|
|
(should (null (cg-sol--col g 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-undo ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-klondike-game))))
|
|
|
|
|
(cg-put g :tableau (vector (list '(1 . 7)) (list '(3 . 6)) nil nil nil nil nil))
|
|
|
|
|
(cg-put g :down (vector 0 0 0 0 0 0 0))
|
|
|
|
|
(cg-sol--snapshot g)
|
|
|
|
|
(let ((cards (last (cg-sol--col g 1) 1)))
|
|
|
|
|
(cg-sol--take g '(col . 1) 1)
|
|
|
|
|
(cg-sol--drop g '(col . 0) cards))
|
|
|
|
|
(should (null (cg-sol--col g 1)))
|
|
|
|
|
(should (cg-sol--restore g))
|
|
|
|
|
(should (equal '((3 . 6)) (cg-sol--col g 1)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-render-builds ()
|
|
|
|
|
(dolist (cls '(cg-klondike-game cg-freecell-game cg-spider-game cg-yukon-game))
|
|
|
|
|
(let ((g (cg-sol--deal (make-instance cls))))
|
|
|
|
|
(should (stringp (cg-render g))))))
|
|
|
|
|
|
|
|
|
|
(defun cgt--init-hearts ()
|
|
|
|
|
(let ((g (cg-hearts-game)))
|
|
|
|
|
(cg-put g :scores (make-vector 4 0))
|
|
|
|
|
(cg-trick--start-hand g) g))
|
|
|
|
|
|
|
|
|
|
(defun cgt--init-spades ()
|
|
|
|
|
(let ((g (cg-spades-game)))
|
|
|
|
|
(cg-put g :scores (make-vector 4 0))
|
|
|
|
|
(cg-put g :bags (make-vector 2 0))
|
|
|
|
|
(cg-put g :dealer 3)
|
|
|
|
|
(cg-trick--deal g)
|
|
|
|
|
(cg-put g :bids (let ((v (make-vector 4 0)))
|
|
|
|
|
(dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v))
|
|
|
|
|
(cg-trick--leader-init g) g))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-trick-deal ()
|
|
|
|
|
(let ((g (cg-trick--deal (cg-hearts-game))))
|
|
|
|
|
(let ((tot 0))
|
|
|
|
|
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
|
|
|
|
|
(should (= 52 tot)))
|
|
|
|
|
(dotimes (s 4) (should (= 13 (length (cg-trick--hand g s)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-trick-winner-trump ()
|
|
|
|
|
(let ((g (cg-spades-game)))
|
|
|
|
|
;; play order: S leads 10h, W 13h(K), N 2s(trump), E 12h
|
|
|
|
|
(cg-put g :trick (list (cons 3 '(3 . 11)) (cons 2 '(0 . 0))
|
|
|
|
|
(cons 1 '(3 . 12)) (cons 0 '(3 . 8))))
|
|
|
|
|
;; :trick is stored reversed (newest first); winner = North (trump)
|
|
|
|
|
(should (= 2 (cg-trick--winner g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-trick-winner-notrump ()
|
|
|
|
|
(let ((g (cg-hearts-game)))
|
|
|
|
|
;; led hearts; highest heart wins (no trump)
|
|
|
|
|
(cg-put g :trick (list (cons 3 '(1 . 12)) (cons 2 '(3 . 12))
|
|
|
|
|
(cons 1 '(3 . 5)) (cons 0 '(3 . 8))))
|
|
|
|
|
;; North played Ace of hearts (3 . 12) -> winner North
|
|
|
|
|
(should (= 2 (cg-trick--winner g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-hearts-first-must-be-2c ()
|
|
|
|
|
(let* ((g (cgt--init-hearts))
|
|
|
|
|
(leader (cg-get g :turn)))
|
|
|
|
|
(let ((moves (cg-trick--legal-moves g leader)))
|
|
|
|
|
(should (equal moves '((1 . 0)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-hearts-full-hand ()
|
|
|
|
|
(let ((g (cgt--init-hearts)))
|
|
|
|
|
(cg-trick--simulate-hand g)
|
|
|
|
|
;; 13 tricks distributed
|
|
|
|
|
(should (= 13 (apply #'+ (append (cg-get g :tricks) nil))))
|
|
|
|
|
;; total points across players is 26 (no moon) or 78 (moon: 3*26)
|
|
|
|
|
(let ((tot (apply #'+ (append (cg-get g :scores) nil))))
|
|
|
|
|
(should (memq tot '(26 78))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-hearts-many-hands ()
|
|
|
|
|
(let ((g (cgt--init-hearts)) (n 0))
|
|
|
|
|
(while (and (not (cg-trick--game-over-p g)) (< n 60))
|
|
|
|
|
(cg-trick--simulate-hand g)
|
|
|
|
|
(cl-incf n)
|
|
|
|
|
(unless (cg-trick--game-over-p g) (cg-trick--start-hand g)))
|
|
|
|
|
(should (cg-trick--game-over-p g))
|
|
|
|
|
(should (integerp (cg-trick--winner-seat g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-spades-bid-range ()
|
|
|
|
|
(let ((g (cg-trick--deal (cg-spades-game))))
|
|
|
|
|
(dotimes (s 4)
|
|
|
|
|
(let ((b (cg-trick--ai-bid g s)))
|
|
|
|
|
(should (and (>= b 1) (<= b 13)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-spades-full-hand ()
|
|
|
|
|
(let ((g (cgt--init-spades)))
|
|
|
|
|
(cg-trick--simulate-hand g)
|
|
|
|
|
(should (= 13 (apply #'+ (append (cg-get g :tricks) nil))))
|
|
|
|
|
;; teammates share a score
|
|
|
|
|
(should (= (aref (cg-get g :scores) 0) (aref (cg-get g :scores) 2)))
|
|
|
|
|
(should (= (aref (cg-get g :scores) 1) (aref (cg-get g :scores) 3)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-spades-full-game ()
|
|
|
|
|
(let ((g (cgt--init-spades)) (n 0))
|
|
|
|
|
(while (and (not (cg-trick--game-over-p g)) (< n 80))
|
|
|
|
|
(cg-trick--simulate-hand g)
|
|
|
|
|
(cl-incf n)
|
|
|
|
|
(unless (cg-trick--game-over-p g)
|
|
|
|
|
(cg-trick--deal g)
|
|
|
|
|
(cg-put g :bids (let ((v (make-vector 4 0)))
|
|
|
|
|
(dotimes (s 4) (aset v s (cg-trick--ai-bid g s))) v))
|
|
|
|
|
(cg-trick--leader-init g)))
|
|
|
|
|
(should (cg-trick--game-over-p g))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-trick-ui-new-and-render ()
|
|
|
|
|
(dolist (cls '(cg-hearts-game cg-spades-game))
|
|
|
|
|
(let ((noninteractive t)
|
|
|
|
|
(g (make-instance cls)))
|
|
|
|
|
(cg-trick--new g) ; spades bids via ai (noninteractive), hearts -> pass phase
|
|
|
|
|
(should (stringp (cg-render g)))
|
|
|
|
|
(should (memq (cg-get g :phase) '(pass play))))))
|
|
|
|
|
(ert-deftest cgt-trick-ui-hearts-pass ()
|
|
|
|
|
(let* ((noninteractive t) (g (make-instance 'cg-hearts-game)))
|
|
|
|
|
(cg-trick--new g)
|
|
|
|
|
;; hand 1 passes left; mark 3 cards from South and pass
|
|
|
|
|
(when (eq (cg-get g :phase) 'pass)
|
|
|
|
|
(cg-put g :marks (cl-subseq (cg-trick--sort (cg-trick--hand g 0)) 0 3))
|
|
|
|
|
(cg-trick--do-pass g)
|
|
|
|
|
(should (eq (cg-get g :phase) 'play))
|
|
|
|
|
;; cards are conserved: hands plus the cards already played this trick
|
|
|
|
|
(let ((tot (length (cg-get g :trick))))
|
|
|
|
|
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
|
|
|
|
|
(should (= 52 tot))))))
|
|
|
|
|
(ert-deftest cgt-trick-ui-spades-human-play ()
|
|
|
|
|
(let* ((noninteractive t) (g (make-instance 'cg-spades-game)))
|
|
|
|
|
(cg-trick--new g) ; runs AI until South's turn
|
|
|
|
|
(should (eq (cg-get g :phase) 'play))
|
|
|
|
|
(should (= 0 (cg-get g :turn)))
|
|
|
|
|
;; play a legal card for South, then run; eventually hand completes/scores
|
|
|
|
|
(let ((guard 0))
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (< guard 20)
|
|
|
|
|
(= 0 (cg-get g :turn)))
|
|
|
|
|
(let ((card (car (cg-trick--legal-moves g 0))))
|
|
|
|
|
(cg-trick--play g 0 card)
|
|
|
|
|
(cg-trick--run g))
|
|
|
|
|
(cl-incf guard)))
|
|
|
|
|
(should (vectorp (cg-get g :scores)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-eights-deal ()
|
|
|
|
|
(let* ((cg-eights-players 3) (g (cg-eights--deal (cg-eights-game))))
|
|
|
|
|
(should (= 3 (cg-get g :nplayers)))
|
|
|
|
|
(dotimes (s 3) (should (= 5 (length (cg-eights--hand g s)))))
|
|
|
|
|
(should (cg-eights--top g))
|
|
|
|
|
(should-not (= cg-eights--wild (cdr (cg-eights--top g)))))) ; starter not an eight
|
|
|
|
|
(ert-deftest cgt-eights-legal ()
|
|
|
|
|
(let ((g (cg-eights-game)))
|
|
|
|
|
(cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0)
|
|
|
|
|
(should (cg-eights--legal-p g '(0 . 8))) ; same suit (spades)
|
|
|
|
|
(should (cg-eights--legal-p g '(1 . 3))) ; same rank
|
|
|
|
|
(should (cg-eights--legal-p g '(2 . 6))) ; eight (wild)
|
|
|
|
|
(should-not (cg-eights--legal-p g '(1 . 4))))) ; neither
|
|
|
|
|
(ert-deftest cgt-eights-full-game ()
|
|
|
|
|
(let* ((cg-eights-players 4) (noninteractive t) (g (cg-eights--deal (cg-eights-game)))
|
|
|
|
|
(guard 0))
|
|
|
|
|
;; drive entirely by AI from every seat
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (< guard 2000))
|
|
|
|
|
(cg-eights--ai-turn g (cg-get g :turn))
|
|
|
|
|
(when (>= (cg-get g :passes) (cg-get g :nplayers)) (cg-eights--deadlock g))
|
|
|
|
|
(cl-incf guard))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (integerp (cg-get g :winner)))))
|
|
|
|
|
(ert-deftest cgt-eights-wild-sets-suit ()
|
|
|
|
|
(let* ((cg-eights-players 2) (g (cg-eights--deal (cg-eights-game))))
|
|
|
|
|
(cg-eights--set-hand g 0 (list '(3 . 6))) ; the human holds only an eight
|
|
|
|
|
(cg-put g :discard (list '(0 . 3))) (cg-put g :suit 0)
|
|
|
|
|
(cg-eights--play g 0 '(3 . 6) 2) ; play it, name diamonds (2)
|
|
|
|
|
(should (= 2 (cg-get g :suit)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))))
|
|
|
|
|
|
|
|
|
|
;;;; --- Wave 2 (2026-06-24): Forty Thieves/Scorpion/Canfield, Golf/TriPeaks/Pyramid, Whist/Oh Hell, President ---
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-forty-deal ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-forty-game))) (tot 0))
|
|
|
|
|
(should (= 10 (oref g ncols)))
|
|
|
|
|
(dotimes (c 10) (should (= 4 (length (cg-sol--col g c)))) (cl-incf tot 4))
|
|
|
|
|
(should (= 8 (oref g nfound)))
|
|
|
|
|
(should (= 64 (length (cg-get g :stock))))
|
|
|
|
|
(should (= 104 (+ tot (length (cg-get g :stock)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-forty-no-redeal ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-forty-game))))
|
|
|
|
|
(cg-put g :stock nil) (cg-put g :waste '((0 . 0) (1 . 1)))
|
|
|
|
|
(cg-sol--stock-action g) ; redeal nil -> stays empty
|
|
|
|
|
(should (null (cg-get g :stock)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-forty-win ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-forty-game))) (found (make-vector 8 nil)))
|
|
|
|
|
(dotimes (i 8) (aset found i (cl-loop for r below 13 collect (cons (mod i 4) r))))
|
|
|
|
|
(cg-put g :found found)
|
|
|
|
|
(should (cg-won-p g))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-scorpion-deal ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-scorpion-game))) (tot 0))
|
|
|
|
|
(should (= 7 (oref g ncols)))
|
|
|
|
|
(dotimes (c 7) (should (= 7 (length (cg-sol--col g c)))) (cl-incf tot 7))
|
|
|
|
|
(dotimes (c 4) (should (= 3 (cg-sol--down g c))))
|
|
|
|
|
(dotimes (k 3) (should (= 0 (cg-sol--down g (+ 4 k)))))
|
|
|
|
|
(should (= 3 (length (cg-get g :stock))))
|
|
|
|
|
(should (= 0 (oref g nfound)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-scorpion-harvest-win ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-scorpion-game))))
|
|
|
|
|
(cg-put g :sets 3)
|
|
|
|
|
;; place a complete K..A clubs run as column 0
|
|
|
|
|
(aset (cg-get g :tableau) 0 (cl-loop for r from 12 downto 0 collect (cons 1 r)))
|
|
|
|
|
(aset (cg-get g :down) 0 0)
|
|
|
|
|
(cg-sol--harvest g)
|
|
|
|
|
(should (= 4 (cg-get g :sets)))
|
|
|
|
|
(should (cg-won-p g))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-canfield-deal ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-canfield-game))))
|
|
|
|
|
(should (= 13 (length (cg-get g :reserve))))
|
|
|
|
|
(should (= 1 (length (aref (cg-get g :found) 0))))
|
|
|
|
|
(dotimes (c 4) (should (= 1 (length (cg-sol--col g c)))))
|
|
|
|
|
(should (= 34 (length (cg-get g :stock))))
|
|
|
|
|
;; base equals the rank of the first foundation card
|
|
|
|
|
(should (= (oref g base) (cdr (car (aref (cg-get g :found) 0)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-canfield-base-wrap ()
|
|
|
|
|
(let ((g (cg-canfield-game)))
|
|
|
|
|
(oset g base 5) (oset g wrap t)
|
|
|
|
|
(cg-put g :found (make-vector 4 nil))
|
|
|
|
|
(should (cg-sol--found-accepts g 1 '(2 . 5))) ; empty -> base rank 5
|
|
|
|
|
(should-not (cg-sol--found-accepts g 1 '(2 . 6)))
|
|
|
|
|
;; wrap: a King on top accepts the Ace next
|
|
|
|
|
(aset (cg-get g :found) 0 (list '(0 . 12)))
|
|
|
|
|
(should (cg-sol--found-accepts g 0 '(0 . 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-sol-canfield-autofill ()
|
|
|
|
|
(let ((g (cg-sol--deal (cg-canfield-game))))
|
|
|
|
|
(let ((rlen (length (cg-get g :reserve))))
|
|
|
|
|
(aset (cg-get g :tableau) 0 nil) ; empty a column
|
|
|
|
|
(cg-sol--autofill g)
|
|
|
|
|
(should (= 1 (length (cg-sol--col g 0))))
|
|
|
|
|
(should (= (1- rlen) (length (cg-get g :reserve)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-golf-deal ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-golf-game))))
|
|
|
|
|
(should (= 35 (length (cg-get g :cards))))
|
|
|
|
|
(should (= 16 (length (cg-get g :stock))))
|
|
|
|
|
(should (= 1 (length (cg-get g :waste))))
|
|
|
|
|
(should (= 7 (length (cg-pat--exposed g)))))) ; one per column (r=4)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-tripeaks-deal ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-tripeaks-game))))
|
|
|
|
|
(should (= 28 (length (cg-get g :cards))))
|
|
|
|
|
(should (= 23 (length (cg-get g :stock))))
|
|
|
|
|
(should (equal (number-sequence 18 27) (cg-pat--exposed g))) ; base row
|
|
|
|
|
(should-not (cg-pat--exposed-p g 0)))) ; apex covered
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-pyramid-deal ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-pyramid-game))))
|
|
|
|
|
(should (= 28 (length (cg-get g :cards))))
|
|
|
|
|
(should (= 24 (length (cg-get g :stock))))
|
|
|
|
|
(should (null (cg-get g :waste)))
|
|
|
|
|
(should (equal (number-sequence 21 27) (cg-pat--exposed g))) ; base row r=6
|
|
|
|
|
(should-not (cg-pat--exposed-p g 0)))) ; apex covered by 1,2
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-exposed-reveal ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-golf-game))))
|
|
|
|
|
;; clear column 0's lower cards; slot 0 (top) becomes exposed
|
|
|
|
|
(dolist (i '(4 3 2 1)) (cg-pat--remove-slot g i))
|
|
|
|
|
(should (cg-pat--exposed-p g 0))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-build-and-win ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-golf-game))))
|
|
|
|
|
;; reduce to one exposed card adjacent to the waste top
|
|
|
|
|
(cg-put g :cards (let ((v (make-vector 35 nil))) (aset v 34 '(0 . 5)) v))
|
|
|
|
|
(cg-put g :waste (list '(1 . 4))) ; 5 of clubs, rank 4; 6s is adjacent
|
|
|
|
|
(cg-put g :stock nil) (cg-put g :cursor 0)
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(setq cg-pat--game g)
|
|
|
|
|
(cg-pat-act)) ; plays slot 34 onto the waste
|
|
|
|
|
(should (null (aref (cg-get g :cards) 34)))
|
|
|
|
|
(should (cg-won-p g))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-sum13 ()
|
|
|
|
|
(let ((g (cg-pat--deal (cg-pyramid-game))))
|
|
|
|
|
;; King value is 13
|
|
|
|
|
(should (= 13 (cg-pat--value '(0 . 12))))
|
|
|
|
|
;; mark two base cards summing to 13 -> both removed
|
|
|
|
|
(cg-put g :cards (let ((v (make-vector 28 nil)))
|
|
|
|
|
(aset v 21 '(0 . 4)) (aset v 22 '(1 . 7)) v)) ; 5 (val5) + 8 (val8) = 13
|
|
|
|
|
(cg-put g :marks nil)
|
|
|
|
|
(cg-pat--toggle-mark g '(slot . 21))
|
|
|
|
|
(cg-pat--toggle-mark g '(slot . 22))
|
|
|
|
|
(should (null (aref (cg-get g :cards) 21)))
|
|
|
|
|
(should (null (aref (cg-get g :cards) 22)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pat-render ()
|
|
|
|
|
(dolist (cls '(cg-golf-game cg-tripeaks-game cg-pyramid-game))
|
|
|
|
|
(let ((g (cg-pat--deal (make-instance cls))))
|
|
|
|
|
(should (stringp (cg-render g))))))
|
|
|
|
|
|
|
|
|
|
(defun cgt--drive (g limit)
|
|
|
|
|
"Play a whole match with AI for every seat, including the human seat 0."
|
|
|
|
|
(let ((n 0))
|
|
|
|
|
(while (and (not (cg-trick--game-over-p g)) (< n limit))
|
|
|
|
|
(when (eq (cg-get g :phase) 'play)
|
|
|
|
|
(cg-trick--play g (cg-get g :turn) (cg-trick--ai-play g (cg-get g :turn)))
|
|
|
|
|
(cg-trick--run g))
|
|
|
|
|
(cl-incf n))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-whist-deal-trump ()
|
|
|
|
|
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
|
|
|
|
|
(cg-trick--new g)
|
|
|
|
|
(should (memq (oref g trump) '(0 1 2 3)))
|
|
|
|
|
(let ((tot (length (cg-get g :trick))))
|
|
|
|
|
(dotimes (s 4) (cl-incf tot (length (cg-trick--hand g s))))
|
|
|
|
|
(should (= 52 tot)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-whist-full-game ()
|
|
|
|
|
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
|
|
|
|
|
(cg-trick--new g)
|
|
|
|
|
(cgt--drive g 400)
|
|
|
|
|
(should (cg-trick--game-over-p g))
|
|
|
|
|
(should (integerp (cg-trick--winner-seat g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-ohhell-rounds ()
|
|
|
|
|
(let ((noninteractive t) (g (make-instance 'cg-ohhell-game)))
|
|
|
|
|
(cg-trick--new g)
|
|
|
|
|
;; first round deals 7 cards each
|
|
|
|
|
(should (= 7 (length (cg-trick--hand g 0))))
|
|
|
|
|
(cgt--drive g 400)
|
|
|
|
|
(should (cg-trick--game-over-p g))
|
|
|
|
|
(should (= 7 (cg-get g :round))) ; seven rounds played
|
|
|
|
|
(should (integerp (cg-trick--winner-seat g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-ohhell-exact-scoring ()
|
|
|
|
|
(let ((g (make-instance 'cg-ohhell-game)))
|
|
|
|
|
(cg-put g :scores (make-vector 4 0))
|
|
|
|
|
(cg-put g :round 0)
|
|
|
|
|
(cg-put g :bids (vector 2 0 1 3))
|
|
|
|
|
(cg-put g :tricks (vector 2 1 1 0)) ; seats 0 and 2 made exact bids
|
|
|
|
|
(cg-trick--score-hand g)
|
|
|
|
|
(should (= 12 (aref (cg-get g :scores) 0))) ; 10 + 2
|
|
|
|
|
(should (= 0 (aref (cg-get g :scores) 1))) ; bid 0 took 1 -> miss
|
|
|
|
|
(should (= 11 (aref (cg-get g :scores) 2))) ; 10 + 1
|
|
|
|
|
(should (= 0 (aref (cg-get g :scores) 3)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-whist-render ()
|
|
|
|
|
(let ((noninteractive t) (g (make-instance 'cg-whist-game)))
|
|
|
|
|
(cg-trick--new g) (should (stringp (cg-render g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-power ()
|
|
|
|
|
(should (> (cg-pres--power 0) (cg-pres--power 12))) ; the Two beats the Ace
|
|
|
|
|
(should (< (cg-pres--power 1) (cg-pres--power 11)))) ; 3 below King
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-deal ()
|
|
|
|
|
(let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (tot 0))
|
|
|
|
|
(should (= 4 (cg-get g :nplayers)))
|
|
|
|
|
(dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s))))
|
|
|
|
|
(should (= 52 tot))
|
|
|
|
|
(should (= 0 (cg-get g :count)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-legal ()
|
|
|
|
|
(let ((g (cg-president-game)))
|
|
|
|
|
(cg-put g :hands (vector (list '(0 . 5) '(1 . 5) '(0 . 8)) nil nil nil))
|
|
|
|
|
(cg-put g :nplayers 4)
|
|
|
|
|
;; leading: any rank ok
|
|
|
|
|
(cg-put g :count 0) (cg-put g :top -1)
|
|
|
|
|
(should (= 2 (length (cg-pres--legal-ranks g 0)))) ; ranks 5 and 8
|
|
|
|
|
;; following a single of power 5: need power>5 -> only rank 8
|
|
|
|
|
(cg-put g :count 1) (cg-put g :top 5)
|
|
|
|
|
(should (equal '(8) (cg-pres--legal-ranks g 0)))
|
|
|
|
|
;; following a PAIR: need 2 of a higher rank -> rank 5 has two but power 5 not >5; none
|
|
|
|
|
(cg-put g :count 2) (cg-put g :top 5)
|
|
|
|
|
(should (null (cg-pres--legal-ranks g 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-full-game ()
|
|
|
|
|
(let* ((cg-president-players 4) (g (cg-pres--deal (cg-president-game))) (n 0))
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (< n 5000))
|
|
|
|
|
(cg-pres--ai-move g (cg-get g :turn))
|
|
|
|
|
(cl-incf n))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (= 4 (length (cg-get g :order)))) ; everyone placed
|
|
|
|
|
(should (= 4 (length (delete-dups (copy-sequence (cg-get g :order)))))))) ; all distinct
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-exchange ()
|
|
|
|
|
(let* ((cg-president-players 4) (g (cg-president-game)))
|
|
|
|
|
;; simulate a prior finishing order, then deal and check the swap happened
|
|
|
|
|
(cg-put g :order '(2 3 1 0)) ; prez=2, scum=0
|
|
|
|
|
(cg-pres--deal g)
|
|
|
|
|
;; conservation: still 52 cards across 4 hands after the exchange
|
|
|
|
|
(let ((tot 0)) (dotimes (s 4) (cl-incf tot (length (cg-pres--hand g s))))
|
|
|
|
|
(should (= 52 tot)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-pres-render ()
|
|
|
|
|
(let ((g (cg-pres--deal (cg-president-game)))) (should (stringp (cg-render g)))))
|
Add the rummy family: meld engine + Gin, Rummy, Rummy 500, Hand & Foot
Introduce a shared meld engine and four games built on it, all on
cg-core/EIEIO with console UNICODE rendering.
* cg-rummy.el: the meld engine and Gin Rummy. Set/run validation,
candidate-meld enumeration, a bitmask-DP minimum-deadwood partition,
and a layoff finder, plus the abstract cg-rummy-game base and shared
render helpers. Gin is two-handed with draw/take/discard/knock, gin
and undercut bonuses, opponent layoffs, and play to 100.
* cg-rum500.el: the abstract cg-tablemeld-game (one mode and command
set, dispatching on the subclass) driving Basic Rummy (meld out;
score the cards left in other hands; to 100) and Rummy 500 (score the
cards you lay down, lose those left in hand; ace high and worth 15;
to 500).
* cg-handfoot.el: Hand & Foot, a partnership Canasta cousin. Hand and
foot packets, Twos and Jokers wild, rank books with clean/dirty piles,
go-out bonus, and partnership scoring to 5000. Deliberately
2026-06-25 05:53:02 -05:00
|
|
|
;;;; Rummy family
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-rummy-set-run ()
|
|
|
|
|
(should (cg-rummy-set-p '((0 . 5) (1 . 5) (2 . 5)) :distinct-suits t))
|
|
|
|
|
(should-not (cg-rummy-set-p '((0 . 5) (0 . 5) (2 . 5)) :distinct-suits t))
|
|
|
|
|
(should (cg-rummy-run-p '((0 . 3) (0 . 4) (0 . 5))))
|
|
|
|
|
(should-not (cg-rummy-run-p '((0 . 3) (1 . 4) (0 . 5))))
|
|
|
|
|
(should (cg-rummy-run-p '((0 . 10) (0 . 11) (0 . 12) (0 . 0)) :ace-high t))
|
|
|
|
|
(should-not (cg-rummy-run-p '((0 . 11) (0 . 12) (0 . 0))))
|
|
|
|
|
(should (cg-rummy-run-p '((0 . 0) (0 . 1) (0 . 2)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-rummy-best-partition ()
|
|
|
|
|
(let* ((hand '((0 . 2)(0 . 3)(0 . 4) (0 . 6)(1 . 6)(2 . 6)
|
|
|
|
|
(3 . 8)(3 . 9)(3 . 10) (3 . 12)))
|
|
|
|
|
(p (cg-rummy-best-partition hand)))
|
|
|
|
|
(should (= 3 (length (plist-get p :melds))))
|
|
|
|
|
(should (= 10 (plist-get p :count))))
|
|
|
|
|
(should (= 0 (cg-rummy-deadwood
|
|
|
|
|
'((0 . 0)(0 . 1)(0 . 2) (1 . 4)(1 . 5)(1 . 6)
|
|
|
|
|
(2 . 8)(2 . 9)(2 . 10)(2 . 11))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-rummy-layoff ()
|
|
|
|
|
(should (cg-rummy-layoff-p '(3 . 11) '(((3 . 8)(3 . 9)(3 . 10)))))
|
|
|
|
|
(should-not (cg-rummy-layoff-p '(0 . 4) '(((3 . 8)(3 . 9)(3 . 10))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-gin-full-game ()
|
|
|
|
|
(let ((g (cg-gin-game)) (turns 0))
|
|
|
|
|
(cg-gin--deal g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 100000))
|
|
|
|
|
(if (eq (cg-get g :phase) 'hand-over)
|
|
|
|
|
(progn (cg-put g :reveal nil) (cg-gin--deal g))
|
|
|
|
|
(cg-gin--ai-turn g (cg-get g :turn)) (cl-incf turns)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (>= (apply #'max (append (cg-get g :scores) nil)) cg-gin-target))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-gin-render () (let ((g (cg-gin--deal (cg-gin-game))))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-tablemeld-games ()
|
|
|
|
|
(dolist (mk (list (lambda () (cg-rummy-basic-game :nplayers 3 :hand-size 7))
|
|
|
|
|
(lambda () (cg-rum500-game :nplayers 3 :hand-size 7))))
|
|
|
|
|
(let ((g (funcall mk)) (turns 0))
|
|
|
|
|
(cg-tm--deal g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< turns 200000))
|
|
|
|
|
(if (eq (cg-get g :phase) 'hand-over)
|
|
|
|
|
(progn (cg-put g :reveal nil) (cg-tm--deal g))
|
|
|
|
|
(cg-tm--ai-turn g (cg-get g :turn)) (cl-incf turns)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-tablemeld-conservation ()
|
|
|
|
|
(let ((g (cg-rum500-game :nplayers 3 :hand-size 7)))
|
|
|
|
|
(cg-tm--deal g)
|
|
|
|
|
(dotimes (_ 30) (when (eq (cg-get g :phase) 'play)
|
|
|
|
|
(cg-tm--ai-turn g (cg-get g :turn))))
|
|
|
|
|
(let ((tot (+ (length (cg-get g :stock)) (length (cg-get g :discard))
|
|
|
|
|
(apply #'+ (mapcar (lambda (r) (length (cdr r))) (cg-get g :table))))))
|
|
|
|
|
(dotimes (s 3) (setq tot (+ tot (length (cg-rummy--hand g s)))))
|
|
|
|
|
(should (= tot 52)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-handfoot-book ()
|
|
|
|
|
(should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(2 . 7))))
|
|
|
|
|
(should (cg-hf--book-valid-p '((0 . 7)(1 . 7)(joker . 0)))) ; dirty
|
|
|
|
|
(should-not (cg-hf--book-valid-p '((0 . 7)(joker . 0)(joker . 0)))) ; wilds > nats
|
|
|
|
|
(should-not (cg-hf--book-valid-p '((0 . 2)(1 . 2)(2 . 2)))) ; threes
|
|
|
|
|
(should (cg-hf--book-complete-p '(a b c d e f g)))
|
|
|
|
|
(should (cg-hf--book-clean-p '((0 . 7)(1 . 7)(2 . 7))))
|
|
|
|
|
(should-not (cg-hf--book-clean-p '((0 . 7)(1 . 7)(joker . 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-handfoot-full-game ()
|
|
|
|
|
(let ((g (cg-handfoot-game)) (rounds 0) (turns 0) (expect (* 5 54)))
|
|
|
|
|
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
|
|
|
|
|
(cg-hf--deal g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 60))
|
|
|
|
|
(cond ((eq (cg-get g :phase) 'round-over)
|
|
|
|
|
(cg-put g :reveal nil) (cg-hf--deal g) (cl-incf rounds))
|
|
|
|
|
(t (cg-hf--ai-turn g (cg-get g :turn)) (cl-incf turns)
|
|
|
|
|
(when (> turns 500000) (error "runaway")))))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
Add nine games: Go Fish, Old Maid, Cribbage, Scopa, Casino,
Euchre, Pitch, Briscola, and Spite & Malice
Five new files, each reusing or extending an existing engine.
* cg-match.el: Go Fish and Old Maid, matching games on a shared
helper set (completes the original wishlist).
* cg-cribbage.el: two-handed Cribbage to 121 -- the crib, the cut,
pegging, and a full show scorer (fifteens, pairs, runs, flush, nobs).
* cg-scopa.el: a capture-by-sum engine driving Scopa (40-card, sette
bello, primiera, scopas) and Casino (pairs and sums, big/little
casino, aces, sweeps). Casino omits builds.
* cg-trick-ext.el: Euchre (24-card with both bowers), Auction Pitch
(bid, pitch sets trump, High/Low/Jack/Game), and Briscola (fixed
trump, no follow), as subclasses of the cg-trick engine.
* cg-spite.el: Spite & Malice, a competitive patience to empty the
goal pile onto shared Ace-to-Queen centre piles; Kings are wild.
Wire all nine commands into the card-game chooser, extend the Makefile
EL list, and add README sections. Add ten ERT tests covering each
game's engine and a full AI-driven game; the suite is now 107/107 and
every file byte-compiles cleanly.
New files at Version 1.0.60 to match the tree; post-1.0.60 work
toward 1.0.90.
2026-06-25 06:31:44 -05:00
|
|
|
;;;; Matching games (Go Fish, Old Maid)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-gofish-full ()
|
|
|
|
|
(let ((cg-go-fish-players 4) (g (cg-go-fish-game)) (guard 0))
|
|
|
|
|
(cg-gf--deal g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000))
|
|
|
|
|
(cg-gf--ai-turn g (cg-get g :turn)) (cl-incf guard))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(let ((tot 0)) (dotimes (s 4) (cl-incf tot (cg-gf--books g s)))
|
|
|
|
|
(should (= tot 13)))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-oldmaid-full ()
|
|
|
|
|
(let ((cg-old-maid-players 4) (g (cg-old-maid-game)) (guard 0))
|
|
|
|
|
(cg-om--deal g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 20000))
|
|
|
|
|
(cg-om--ai-turn g (cg-get g :turn)) (cl-incf guard))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (= 1 (cg-om--total g)))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
|
|
|
|
|
|
|
|
|
;;;; Cribbage
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-cribbage-scorer ()
|
|
|
|
|
(should (= 29 (cg-crib--score-show '((0 . 4)(1 . 4)(3 . 4)(2 . 10)) '(2 . 4))))
|
|
|
|
|
(should (= 12 (cg-crib--count-pairs '((0 . 4)(1 . 4)(2 . 4)(3 . 4)))))
|
|
|
|
|
(should (= 5 (cg-crib--count-runs '((0 . 1)(0 . 2)(0 . 3)(0 . 4)(0 . 5)))))
|
|
|
|
|
(should (= 2 (cg-crib--peg-score '((0 . 10)(0 . 4)) 15)))
|
|
|
|
|
(should (= 3 (cg-crib--peg-score '((0 . 2)(0 . 3)(0 . 4)) 12)))
|
|
|
|
|
(should (= 6 (cg-crib--peg-score '((0 . 6)(1 . 6)(2 . 6)) 21))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-cribbage-full ()
|
|
|
|
|
(let ((g (cg-cribbage-game)) (deals 0))
|
|
|
|
|
(cg-put g :dealer 1)
|
|
|
|
|
(cl-flet ((ai-deal (g)
|
|
|
|
|
(cg-crib--deal g)
|
|
|
|
|
(let ((d0 (cg-crib--ai-discard g 0)) (d1 (cg-crib--ai-discard g 1)))
|
|
|
|
|
(cg-crib--set-hand g 0 (cl-set-difference (cg-crib--hand g 0) d0 :test #'equal))
|
|
|
|
|
(cg-crib--set-hand g 1 (cl-set-difference (cg-crib--hand g 1) d1 :test #'equal))
|
|
|
|
|
(cg-put g :crib (append d0 d1)))
|
|
|
|
|
(cg-crib--start-play g)
|
|
|
|
|
(let ((guard 0))
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (not (cg-crib--peg-over-p g))
|
|
|
|
|
(< guard 400))
|
|
|
|
|
(cl-incf guard)
|
|
|
|
|
(let ((s (cg-get g :pturn)))
|
|
|
|
|
(if (cg-crib--legal g s) (cg-crib--ai-play g s) (cg-crib--peg-go g s)))))
|
|
|
|
|
(when (and (eq (cg-get g :phase) 'play) (cg-crib--peg-over-p g))
|
|
|
|
|
(cg-crib--show g))))
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< deals 300))
|
|
|
|
|
(cg-put g :dealer (- 1 (cg-get g :dealer)))
|
|
|
|
|
(ai-deal g) (cl-incf deals)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
|
|
|
|
|
|
|
|
|
;;;; Fishing games (Scopa, Casino)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-fish-capture ()
|
|
|
|
|
(let ((g (cg-scopa-game)))
|
|
|
|
|
(cg-put g :table '((0 . 0)(1 . 1)(2 . 3)))
|
|
|
|
|
(should (equal (sort (mapcar #'cdr (cg-fish--capture g '(3 . 4))) #'<) '(0 3))))
|
|
|
|
|
(let ((g (cg-casino-game)))
|
|
|
|
|
(cg-put g :table '((0 . 12)(1 . 12)(2 . 5)))
|
|
|
|
|
(should (= 1 (length (cg-fish--capture g '(3 . 12)))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-fish-full ()
|
|
|
|
|
(dolist (mk (list #'cg-scopa-game #'cg-casino-game))
|
|
|
|
|
(let ((g (funcall mk)) (rounds 0))
|
|
|
|
|
(cg-fish--deal-round g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< rounds 200))
|
|
|
|
|
(if (eq (cg-get g :phase) 'round-over)
|
|
|
|
|
(cg-fish--deal-round g)
|
|
|
|
|
(cg-fish--ai-play g (cg-get g :turn)) (cl-incf rounds)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g))))))
|
|
|
|
|
|
|
|
|
|
;;;; Trick extensions (Euchre, Pitch, Briscola)
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-euchre-bowers ()
|
|
|
|
|
(should (> (cg-euchre--power '(0 . 9) 0 0) (cg-euchre--power '(1 . 9) 0 0)))
|
|
|
|
|
(should (> (cg-euchre--power '(1 . 9) 0 0) (cg-euchre--power '(0 . 12) 0 0)))
|
|
|
|
|
(should (= 120 (let ((s 0)) (dolist (su '(0 1 2 3))
|
|
|
|
|
(dolist (r cg-briscola--ranks)
|
|
|
|
|
(setq s (+ s (cg-bris--points (cons su r)))))) s))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-trick-ext-full ()
|
|
|
|
|
(dolist (class '(cg-briscola-game cg-pitch-game cg-euchre-game))
|
|
|
|
|
(let ((g (make-instance class)) (guard 0))
|
|
|
|
|
(cg-trick--new g)
|
|
|
|
|
(while (and (not (eq (cg-get g :phase) 'game-over)) (< guard 50000))
|
|
|
|
|
(cl-incf guard)
|
|
|
|
|
(if (cg-trick--hand-over-p g)
|
|
|
|
|
(cg-trick--finish-hand g)
|
|
|
|
|
(let ((s (cg-get g :turn)))
|
|
|
|
|
(cg-trick--play g s (cg-trick--ai-play g s)))))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g))))))
|
|
|
|
|
|
|
|
|
|
;;;; Spite & Malice
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-spite-legal ()
|
|
|
|
|
(let ((g (cg-spite-game)))
|
|
|
|
|
(cg-spite--deal g) (cg-put g :center (make-vector 4 nil))
|
|
|
|
|
(should (eql 0 (cg-spite--legal-center g '(0 . 0)))) ; Ace starts a pile
|
|
|
|
|
(should (null (cg-spite--legal-center g '(0 . 1)))) ; a Two cannot
|
|
|
|
|
(should (eql 0 (cg-spite--legal-center g '(0 . 12)))) ; King is wild
|
|
|
|
|
(cg-spite--put-center g '(0 . 0) 0)
|
|
|
|
|
(should (= 1 (cg-spite--needed g 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-spite-full ()
|
|
|
|
|
(let ((cg-spite-goal-size 10) (g (cg-spite-game)) (turns 0))
|
|
|
|
|
(cg-spite--deal g)
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (< turns 6000))
|
|
|
|
|
(cl-incf turns) (cg-spite--ai-turn g (cg-get g :turn)))
|
|
|
|
|
(should (eq (cg-get g :phase) 'game-over))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
Add Contract Bridge: auction, dummy play, and rubber scoring
New cg-bridge.el: a four-handed Bridge game (you are South, partnering
North against East and West) on the shared cg-game base.
* Auction: level/strain bids plus pass, double, and redouble, with the
three-pass end rule, pass-outs, doubling state, and declarer
determination (first of the side to name the strain).
* Play: follow-suit with the dummy exposed after the opening lead; the
declarer plays both hands. Trick resolution honours trump and no-trump.
* Scoring: classic rubber -- trick points below the line toward game;
overtricks, slam, insult, and undertrick penalties above; vulnerability
and the rubber bonus. Verified against known results.
* A small natural bidding AI (openings, NT, raises with a fit, simple
overcalls) that always terminates the auction, plus a greedy
card-play AI.
Wire cg-bridge into the chooser, the Makefile, and the README, and add
two ERT tests (scoring math and a dozen full AI-driven deals). The suite
is now 109/109 and every file byte-compiles cleanly.
2026-06-25 06:53:51 -05:00
|
|
|
;;;; Bridge
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bridge-score ()
|
|
|
|
|
(cl-flet ((b (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :below))
|
|
|
|
|
(a (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :datk))
|
|
|
|
|
(f (l s d v tk) (plist-get (cg-bridge--deal-score l s d v tk) :defend)))
|
|
|
|
|
(should (= 100 (b 3 4 0 nil 9))) ; 3NT made
|
|
|
|
|
(should (= 120 (b 4 3 0 nil 10))) ; 4 spades made
|
|
|
|
|
(should (= 180 (b 6 2 0 nil 12))) ; 6 hearts made
|
|
|
|
|
(should (= 500 (a 6 2 0 nil 12))) ; small slam bonus
|
|
|
|
|
(should (= 50 (a 1 4 1 nil 7))) ; 1NT doubled, insult
|
|
|
|
|
(should (= 100 (f 4 3 0 nil 8))) ; down two undoubled
|
|
|
|
|
(should (= 500 (f 4 3 1 t 8)))) ; down two doubled vulnerable
|
|
|
|
|
(should (= 1 (cg-bridge--trick-winner
|
|
|
|
|
'((0 . (0 . 12)) (1 . (3 . 0)) (2 . (0 . 2)) (3 . (0 . 5))) 3))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bridge-full ()
|
|
|
|
|
(let ((scored 0) (passed 0))
|
|
|
|
|
(dotimes (i 12)
|
|
|
|
|
(let ((g (cg-bridge-game)) (guard 0))
|
|
|
|
|
(cg-put g :dealer (mod i 4))
|
|
|
|
|
(cg-bridge--deal g)
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'auction) (< guard 60))
|
|
|
|
|
(cl-incf guard)
|
|
|
|
|
(let* ((s (cg-get g :bidder)) (call (cg-bridge--ai-call g s)))
|
|
|
|
|
(unless (cg-bridge--legal-call-p g call) (setq call 'pass))
|
|
|
|
|
(cg-bridge--apply-call g s call)
|
|
|
|
|
(cg-bridge--auction-done-p g)))
|
|
|
|
|
(if (eq (cg-get g :phase) 'passed-out) (cl-incf passed)
|
|
|
|
|
(let ((p 0))
|
|
|
|
|
(while (and (eq (cg-get g :phase) 'play) (< p 60))
|
|
|
|
|
(cl-incf p)
|
|
|
|
|
(cg-bridge--play-card g (cg-get g :turn) (cg-bridge--ai-play g (cg-get g :turn)))))
|
|
|
|
|
(when (eq (cg-get g :phase) 'scored)
|
|
|
|
|
(cl-incf scored)
|
|
|
|
|
(should (cl-every #'null (append (cg-get g :hands) nil)))))
|
|
|
|
|
(should (memq (cg-get g :phase) '(scored passed-out)))
|
|
|
|
|
(should (stringp (cg-render g)))))
|
|
|
|
|
(should (> scored 0))))
|
2026-06-25 09:10:42 -05:00
|
|
|
;;;; Renderer registry / region keystone
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-keystone-regions ()
|
|
|
|
|
(let* ((g (cg-sol--deal (make-instance 'cg-klondike-game)))
|
|
|
|
|
(res (cg-render-svg g)))
|
|
|
|
|
(should (stringp (car res)))
|
|
|
|
|
(should (>= (length (cdr res)) 13)) ; 6 top slots + 7 columns
|
|
|
|
|
(let* ((reg (cl-find '(col . 3) (cdr res) :key #'cdr :test #'equal))
|
|
|
|
|
(rect (car reg)))
|
|
|
|
|
(should reg)
|
|
|
|
|
(should (equal '(col . 3)
|
|
|
|
|
(cg-regions-hit (cdr res)
|
|
|
|
|
(+ (nth 0 rect) (/ (nth 2 rect) 2))
|
|
|
|
|
(+ (nth 1 rect) 10)))))
|
|
|
|
|
(should (null (cg-regions-hit (cdr res) -5 -5))))
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(setq cg-sol--game (cg-sol--deal (make-instance 'cg-klondike-game)))
|
|
|
|
|
(cg-render-game cg-sol--game)
|
|
|
|
|
(should (oref cg-sol--game renderer))
|
|
|
|
|
(should (> (buffer-size) 0))
|
|
|
|
|
(cg-render-apply cg-sol--game '(col . 5))
|
|
|
|
|
(should (= 11 (cg-get cg-sol--game :cursor))))) ; spot index of (col . 5)
|
2026-06-25 09:53:56 -05:00
|
|
|
;;;; Hand-cluster click regions + card-size slider
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-hand-regions ()
|
|
|
|
|
(let* ((cards '((0 . 0) (0 . 1) (1 . 5)))
|
|
|
|
|
(str (cg-rummy--svg-row cards 0 nil nil 'hand))
|
|
|
|
|
(regs (get-text-property 0 'cg-regions str)))
|
|
|
|
|
(should (= (+ 3 (length cg-svg-slider-stops)) (length regs))) ; 3 cards + stops
|
|
|
|
|
(should (equal '(hand . 0) (cdr (car regs))))
|
|
|
|
|
(should (cl-find-if (lambda (r) (eq (car-safe (cdr r)) 'scale)) regs)))
|
|
|
|
|
(let ((g (cg-gin--deal (cg-gin-game))) (cg-card-scale 1.0))
|
|
|
|
|
(cg-render-apply g '(hand . 2))
|
|
|
|
|
(should (= 2 (cg-get g :cursor)))
|
|
|
|
|
(cg-render-apply g '(scale . 1.5)) ; base method handles scale
|
|
|
|
|
(should (= 1.5 cg-card-scale))
|
|
|
|
|
(cg-render-apply g 'zoom-reset)
|
|
|
|
|
(should (= 1.0 cg-card-scale))))
|
2026-06-26 16:34:02 -05:00
|
|
|
|
|
|
|
|
;;;; Rummy 500 deep pickup and Hand & Foot rule completions
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-rum500-deep-pickup ()
|
|
|
|
|
"Taking a buried discard card melds it at once, keeping the cards above."
|
|
|
|
|
(let ((g (cg-rum500-game :nplayers 2 :hand-size 10)))
|
|
|
|
|
(cg-put g :nplayers 2) (cg-put g :scores (make-vector 2 0))
|
|
|
|
|
(cg-put g :hands (vector (list (cons 0 5) (cons 0 6)) nil)) ; 6S 7S
|
|
|
|
|
(cg-put g :discard (list (cons 1 9) (cons 0 4) (cons 2 3))) ; top 10C, buried 5S
|
|
|
|
|
(cg-put g :table nil) (cg-put g :laid (make-vector 2 0))
|
|
|
|
|
(cg-put g :turn 0) (cg-put g :step 'draw) (cg-put g :phase 'play)
|
|
|
|
|
(should (cg-tm--take-deep g 0 1))
|
|
|
|
|
(should (equal (cg-get g :table) '((0 (0 . 4) (0 . 5) (0 . 6)))))
|
|
|
|
|
(should (equal (cg-rummy--hand g 0) '((1 . 9))))
|
|
|
|
|
(should (= 1 (length (cg-get g :discard))))
|
|
|
|
|
;; a card you cannot use immediately may not be taken
|
|
|
|
|
(cg-put g :hands (vector (list (cons 3 11)) nil))
|
|
|
|
|
(cg-put g :discard (list (cons 1 9) (cons 2 2)))
|
|
|
|
|
(should-not (cg-tm--take-deep g 0 1))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-handfoot-redthree ()
|
|
|
|
|
"Red threes leave the hand on deal and collect to the team pile."
|
|
|
|
|
(let ((g (cg-handfoot-game)))
|
|
|
|
|
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
|
|
|
|
|
(cg-hf--deal g)
|
|
|
|
|
(dotimes (s 4)
|
|
|
|
|
(should (= 0 (cl-count-if #'cg-hf--red-three-p (cg-rummy--hand g s)))))
|
|
|
|
|
(cg-put g :redthrees (make-vector 2 nil))
|
|
|
|
|
(cg-rummy--set-hand g 0 (list (cons 2 2) (cons 0 5))) ; 3 of diamonds + 6S
|
|
|
|
|
(cg-put g :stock (list (cons 0 9)))
|
|
|
|
|
(should (= 1 (cg-hf--collect-red-threes g 0)))
|
|
|
|
|
(should (= 1 (length (aref (cg-get g :redthrees) (cg-hf--team g 0)))))
|
|
|
|
|
(should-not (cl-find-if #'cg-hf--red-three-p (cg-rummy--hand g 0)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-handfoot-min-meld ()
|
|
|
|
|
"Initial meld must reach the round minimum; below it is refused."
|
|
|
|
|
(let ((g (cg-handfoot-game)))
|
|
|
|
|
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
|
|
|
|
|
(cg-hf--deal g) (cg-put g :round 0)
|
|
|
|
|
(cg-put g :down (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil))
|
|
|
|
|
(cg-put g :hands (vector (list (cons 0 3)(cons 1 3)(cons 2 3)) nil nil nil)) ; three 4s = 15
|
|
|
|
|
(should-not (cg-hf--initial-meld g 0 (cg-rummy--hand g 0)))
|
|
|
|
|
(should-not (cg-hf--down-p g 0))
|
|
|
|
|
(cg-put g :hands (vector (list (cons 0 0)(cons 1 0)(cons 2 0)) nil nil nil)) ; three aces = 60
|
|
|
|
|
(should (cg-hf--initial-meld g 0 (cg-rummy--hand g 0)))
|
|
|
|
|
(should (cg-hf--down-p g 0))
|
|
|
|
|
(should (= 1 (length (cg-hf--books g 0))))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-handfoot-pickup ()
|
|
|
|
|
"Picking up melds the top discard and rakes in the cards beneath it."
|
|
|
|
|
(let ((g (cg-handfoot-game)))
|
|
|
|
|
(cg-put g :nplayers 4) (cg-put g :nteams 2) (cg-put g :scores (make-vector 2 0))
|
|
|
|
|
(cg-hf--deal g)
|
|
|
|
|
(cg-put g :redthrees (make-vector 2 nil)) (cg-put g :books (make-vector 2 nil))
|
|
|
|
|
(cg-put g :hands (vector (list (cons 0 8)(cons 1 8)(cons 0 4)) nil nil nil)) ; two 9s + 5S
|
|
|
|
|
(cg-put g :discard (list (cons 2 8)(cons 3 5)(cons 0 6)(cons 1 7))) ; top 9D + 3 beneath
|
|
|
|
|
(cg-put g :stock nil)
|
|
|
|
|
(should (cg-hf--pickup-eligible g 0))
|
|
|
|
|
(let ((top (cg-hf--pickup g 0)))
|
|
|
|
|
(should (equal top (cons 2 8)))
|
|
|
|
|
(should (= 1 (length (cg-hf--books g 0))))
|
|
|
|
|
(should (cg-hf--book-valid-p (car (cg-hf--books g 0))))
|
|
|
|
|
(should (= 4 (length (cg-rummy--hand g 0))))
|
|
|
|
|
(should-not (cg-get g :discard)))))
|
2026-06-26 16:43:33 -05:00
|
|
|
|
|
|
|
|
;;;; Mouse click-region wiring for eights, president, and the patience boards
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-mouse-regions ()
|
|
|
|
|
"The newly clickable games attach a `cg-regions' map to their SVG."
|
|
|
|
|
(let* ((g (cg-pat--deal (cg-golf-game)))
|
|
|
|
|
(regs (get-text-property 0 'cg-regions (cg-pat--svg g))))
|
|
|
|
|
(should regs)
|
|
|
|
|
(should (cl-find '(waste . 0) (mapcar #'cdr regs) :test #'equal))
|
|
|
|
|
(should (cl-find '(stock . 0) (mapcar #'cdr regs) :test #'equal))
|
|
|
|
|
(should (cl-find-if (lambda (a) (eq (car a) 'slot)) (mapcar #'cdr regs))))
|
|
|
|
|
(let ((g (cg-president-game)))
|
|
|
|
|
(cg-put g :games 0) (cg-pres--deal g)
|
|
|
|
|
(let ((regs (get-text-property 0 'cg-regions (cg-pres--svg g))))
|
|
|
|
|
(should regs)
|
|
|
|
|
(should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand)))
|
|
|
|
|
(mapcar #'cdr regs)))))
|
|
|
|
|
(let ((g (cg-eights-game)))
|
|
|
|
|
(cg-put g :scores (make-vector 3 0)) (cg-eights--deal g)
|
|
|
|
|
(let* ((img (cg-svg-hand-image (mapcar #'cg-eights--spec (cg-eights--hand g 0))
|
|
|
|
|
:region-tag 'hand))
|
|
|
|
|
(regs (get-text-property 0 'cg-regions img)))
|
|
|
|
|
(should regs)
|
|
|
|
|
(should (cl-find-if (lambda (a) (and (consp a) (eq (car a) 'hand)))
|
|
|
|
|
(mapcar #'cdr regs))))))
|
Cut 1.0.90 pretest: 500 mouse UX, version bump, NEWS, docs
Full-SVG 500 made mouse-operable for newcomers: kitty Discard button and
five-card cap, on-table phase banner, ? Help/Rules overlay with the bid
legend, legal-play dimming, card-size slider, and a layout pass that
moves the Help and size controls into the log panel so nothing overlaps.
Bump all files to 1.0.90, add NEWS, a README testing quick-start, and
make the shared engine files checkdoc-clean.
2026-06-26 18:48:31 -05:00
|
|
|
|
|
|
|
|
;;;; 500 SVG-UI: kitty discard cap and on-screen controls
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bid-kitty-cap ()
|
|
|
|
|
"Kitty marking never exceeds five cards, and the UI exposes the controls."
|
|
|
|
|
(let ((g (cg-bid-game)) (cg-bid--human-seats '(0)))
|
|
|
|
|
(cg-bid--deal g 3)
|
|
|
|
|
(cg-put g :phase 'kitty) (cg-put g :contractor 0)
|
|
|
|
|
(cg-put g :contract (nth 0 cg-bid-schedule))
|
|
|
|
|
(let ((hand (cg-bid-sort-display (cg-bid--hand g 0) nil)))
|
|
|
|
|
(cg-put g :sorted-hand hand)
|
|
|
|
|
(cg-put g :marks (cl-subseq hand 0 5)) ; already five
|
|
|
|
|
(cg-put g :cursor 5) ; a sixth, unmarked
|
|
|
|
|
(with-temp-buffer
|
|
|
|
|
(setq-local cg-bid--game g)
|
|
|
|
|
(cg-bid-select) ; must refuse the sixth
|
|
|
|
|
(should (= 5 (length (cg-get g :marks))))
|
|
|
|
|
;; unmark a card that is actually marked (redisplay may have re-sorted
|
|
|
|
|
;; the hand by trump, so cursor 0 is not necessarily a marked card)
|
|
|
|
|
(let* ((sh (cg-get g :sorted-hand)) (mk (cg-get g :marks))
|
|
|
|
|
(idx (cl-position-if (lambda (c) (member c mk)) sh)))
|
|
|
|
|
(cg-put g :cursor idx)
|
|
|
|
|
(cg-bid-select)
|
|
|
|
|
(should (= 4 (length (cg-get g :marks)))))))
|
|
|
|
|
;; the full-SVG kitty panel exposes a Discard region and a card-size slider
|
|
|
|
|
(let* ((cg-bid-svg-ui t) (cg-bid-svg-fill t)
|
|
|
|
|
(rg (cdr (cg-bid--ui-svg g 1100 700))))
|
|
|
|
|
(should (plist-get rg :discard))
|
|
|
|
|
(should (plist-get rg :sizer)))))
|
|
|
|
|
|
|
|
|
|
(ert-deftest cgt-bid-svg-controls ()
|
|
|
|
|
"The full-SVG UI exposes Help and, when open, the overlay's buttons."
|
|
|
|
|
(let ((g (cg-bid-game)) (cg-bid-svg-ui t) (cg-bid-svg-fill t))
|
|
|
|
|
(cg-bid--deal g 3)
|
|
|
|
|
(cg-put g :phase 'auction) (cg-put g :bidder 0)
|
|
|
|
|
(let ((rg (cdr (cg-bid--ui-svg g 1100 700))))
|
|
|
|
|
(should (plist-get rg :help))
|
|
|
|
|
(should-not (plist-get rg :help-close)))
|
|
|
|
|
(cg-put g :help-open t)
|
|
|
|
|
(let ((rg (cdr (cg-bid--ui-svg g 1100 700))))
|
|
|
|
|
(should (plist-get rg :help-close))
|
|
|
|
|
(should (plist-get rg :help-classic))
|
|
|
|
|
(should (plist-get rg :help-quit)))))
|