Corwin Brust
2345f7e1a6
Host-authoritative networked 500: host sits South, joiners take W/N/E, open seats filled by AI. Per-seat rotated state hides other hands and the kitty; clients reuse the single-player renderer/commands via :around advice, so cg-bid.el/cg-bid-ui.el are untouched. Adds cg-bid-host/cg-bid-join, a start-now lobby with auto-start at four players, and cg-bid-shuffle-partners. cg-net.el gains cg-net-connect-functions. Verified: clean byte-compile, checkdoc, 34/34 ERT (incl. 3 new net tests) and a two-process TCP game.
334 lines
14 KiB
EmacsLisp
334 lines
14 KiB
EmacsLisp
;;; 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"))))
|
|
|
|
(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))))
|
|
|
|
;;;; 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))))
|
|
|
|
;;;; 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
|
|
|
|
;;;; 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)))))
|