gamao/test/main.lisp

;;;; test/main.lisp

(in-package #:gamao/test)

(defvar *error-on-failing-tests* nil)

(defun run-all ()
  (let ((test-results (multiple-value-list (run! 'all-tests))))
    (when (and (not (first test-results)) *error-on-failing-tests*)
      (error "There were failing tests."))
    (values-list test-results)))

(def-suite all-tests
  :description "All gamao tests")

(def-suite checker-game
  :in all-tests)

(in-suite checker-game)

(def-fixture pvector-test-fixture ()
  (let* ((v1 (make-pvector 3 :initial-contents '(1 2 3)))
         (v2 (pvector-update v1 0 -1))
         (v3 (pvector-update v2 1 -2)))
    (pvector-reroot v2)
    (&body)))


(test pvector-test
  (with-fixture pvector-test-fixture ()
    (is (= 1 (pvector-ref v1 0)))
    (is (= -1 (pvector-ref v2 0)))
    (is (= -2 (pvector-ref v3 1)))))

(test pvector-reroot-test
  (is (= (pvector-ref (pvector-reroot (pvector-update (pvector-update (make-pvector 28 :initial-element 0) 0 3) 25 1)) 25) 1)))

(def-fixture checker-position-test-fixture ()
  (let* ((p1 (make-checker-position))
         (p2 (update-checker-position p1 1 :black 3))
         (p3 (update-checker-position p2 :off :white 1))
         (p4 (update-checker-position p3 :bar :white 1)))
    (&body)))

(test checker-position-test
  (with-fixture checker-position-test-fixture ()
    (is (typep p1 'checker-position) )
    (is (= 3 (checker-position-checkers-at p2 1 :black)))
    (is (= 3 (checker-position-checkers-at p4 1 :black)))
    (is (= 0 (checker-position-checkers-at p4 1 :white)))
    (is (eq :white (nth-value 1 (checker-position-checkers-at p4 1 :white))))
    (is (eq :black (nth-value 1 (checker-position-checkers-at p4 1 :black))))
    (is (eq :black (nth-value 1 (checker-position-checkers-at p4 2 :black))))
    (is (null (nth-value 1 (checker-position-checkers-at p4 2 nil))))
    (is (= 1 (checker-position-checkers-at p4 :off :white)))
    (is (eq :white (nth-value 1 (checker-position-checkers-at p4 :off :white))))
    (is (= 1 (checker-position-checkers-at p4 :bar :white)))
    (is (eq :white (nth-value 1 (checker-position-checkers-at p4 :bar :white))))
    (is (= 0 (checker-position-checkers-at p4 :off :black)))
    (is (eq :black (nth-value 1 (checker-position-checkers-at p4 :off :black))))
    (signals type-error (checker-position-checkers-at p4 :black :off))))

(test opponent-test
  (is (eq :white (opponent :black)))
  (is (eq :black (opponent :white)))
  (signals simple-type-error (opponent nil)))

(def-fixture backgammon-game-fixture (&key (cube 1) checkers)
  (let ((game (if (null checkers)
                  (make-instance 'backgammon-game :cube cube :checkers (gamao-impl::make-initial-backgammon-position))
                  (make-instance 'backgammon-game
                                 :cube cube
                                 :checker-position (loop with checker-position = (make-checker-position)
                                                         for update in checkers
                                                         do (apply #'update-checker-position checker-position update))))))
    (&body)))

(test backgammon-game-test
  (with-fixture backgammon-game-fixture ()
    ;; First turn: undecided, then black
    (is (new-dice game 1 1))
    (is (null (current-player game)))
    (is (new-dice game 2 1))
    (is (eq :black (current-player game)))
    (is (= 2 (remaining-dice-count game)))
    ;; Black must roll dice before moving checkers
    (is (null (move-checker game :white 1 1)))
    (is (null (move-checker game :black 13 1)))
    (is (move-checker game :black 24 1))
    (is (= 1 (remaining-dice-count game)))
    ;; Undo
    (is (undo-move game :black))
    (is (= 2 (remaining-dice-count game)))
    (is (null (undo-move game :black)))
    (is (move-checker game :black 24 1))
    ;; Pick-up
    (is (null (pick-up-dice game :black)))
    (is (move-checker game :black 13 2))
    (is (pick-up-dice game :black))
    ;; Current player changed to :white
    (is (eq :white (current-player game)))
    (is (null (new-dice game 6 4)))
    (is (roll-dice game :white))
    (is (dice-rolling-p game))
    (is (new-dice game 6 4))
    (is (not (dice-rolling-p game)))
    (is (move-checker game :white 1 6))
    (is (move-checker game :white 7 4))
    (is (pick-up-dice game :white))
    (is (roll-dice game :black))
    (is (new-dice game 6 6))
    ;; Black is hit and cannot enter
    (is (zerop (remaining-dice-count game)))
    (is (pick-up-dice game :black))
    ;; White doubles, black accepts
    (is (null (cube-owner game)))
    (is (not (cube-offered-p game)))
    (is (not (offer-double game :black)))
    (is (offer-double game :white))
    (is (cube-offered-p game))
    (is (eq :black (current-player game)))
    (is (accept-double game :black))
    (is (eq :white (current-player game)))
    (is (eq :black (cube-owner game)))
    ;; White can only roll dice
    (is (null (offer-double game :white)))
    (is (roll-dice game :white))
    (is (new-dice game 2 1))
    (is (move-checker game :white 1 1))
    (is (move-checker game :white 2 2))
    (is (pick-up-dice game :white))
    ;; Black redoubles, white drops.
    (is (offer-double game :black))
    (is (null (winner game)))
    (is (reject-double game :white))
    (is (eq :black (winner game)))
    (is (eq :single (game-result game)))
    (is (= 2 (game-score game)))
    ))

(defun checker-position-from-list (list)
  (loop with checker-position = (make-checker-position)
        for update in list
        do (setf checker-position (apply #'update-checker-position checker-position update))
        finally (return checker-position)))

;;; A few end game tests.
(def-fixture backgammon-game-fixture-2 ()
  (let* ((game (make-instance 'backgammon-game
                              :cube nil
                              :checkers (checker-position-from-list '((3 :black 1)
                                                                      (:off :black 14)
                                                                      (24 :white 14)
                                                                      (:off :white 1))))))
    (setf (current-player game) :black)
    (roll-dice game :black)
    (new-dice game 1 4)
    (&body)))

;; When one checker remains, one may bear it off using one die or both dice.
(test backgammon-game-test-2
  (with-fixture backgammon-game-fixture-2 ()
    (is (may-move-checker-p game :black 3 1))
    (is (move-checker game :black 3 4))
    (is (eq :black (winner game)))
    (is (eq :single (game-result game)))
    ;; Make sure borne off checkers are not `hit'.
    (is (= 1 (checker-position-checkers-at (checkers game) :off :white)))
    (is (zerop (checker-position-checkers-at (checkers game) :bar :white)))
    ))

;; gammons, backgammons
(def-fixture backgammon-game-fixture-3 (&key game-class cube checkers)
  (let* ((game (make-instance game-class
                              :cube cube
                              :checkers (checker-position-from-list checkers))))
    (setf (current-player game) :black)
    (roll-dice game :black)
    (new-dice game 1 4)
    (move-checker game :black 3 4)
    (&body)))

;; single
(test backgammon-game-test-3a
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game
                                           :cube 1
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 14)
                                                       (:off :white 1)))
    (is (eq :black (winner game)))
    (is (eq :single (game-result game)))
    (is (= 1 (game-score game)))))

;; gammon
(test backgammon-game-test-3b
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game
                                           :cube 2
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 15)))
    (is (eq :black (winner game)))
    (is (eq :gammon (game-result game)))
    (is (= 4 (game-score game)))))

;; backgammon: one at home
(test backgammon-game-test-3c
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game
                                           :cube nil
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 14)
                                                       (4 :white 1)))
    (is (eq :black (winner game)))
    (is (eq :backgammon (game-result game)))
    (is (= 3 (game-score game)))))

;; backgammon: one on bar
(test backgammon-game-test-3d
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game
                                           :cube nil
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 14)
                                                       (:bar :white 1)))
    (is (eq :black (winner game)))
    (is (eq :backgammon (game-result game)))
    (is (= 3 (game-score game)))))

;; single: one on bar, one at home, but one is off
(test backgammon-game-test-3e
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game
                                           :cube nil
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 12)
                                                       (4 :white 1)
                                                       (:bar :white 1)
                                                       (:off :white 1)))
    (is (eq :black (winner game)))
    (is (eq :single (game-result game)))
    (is (= 1 (game-score game)))))

;; single: one on bar, one at home, cube = 1, Jacoby rule
(test backgammon-game-test-3f
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game-with-jacoby
                                           :cube 1
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 13)
                                                       (4 :white 1)
                                                       (:bar :white 1)))
    (is (eq :black (winner game)))
    (is (eq :single (game-result game)))
    (is (= 1 (game-score game))))) 

;; gammon, cube = 2, Jacoby rule
(test backgammon-game-test-3g
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game-with-jacoby
                                           :cube 2
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (24 :white 15)))
    (is (eq :black (winner game)))
    (is (eq :gammon (game-result game)))
    (is (= 4 (game-score game)))))

;; backgammon, cube = 4, Jacoby rule
(test backgammon-game-test-3h
  (with-fixture backgammon-game-fixture-3 (:game-class 'backgammon-game-with-jacoby
                                           :cube 4
                                           :checkers '((3 :black 1)
                                                       (:off :black 14)
                                                       (4 :white 15)))
    (is (eq :black (winner game)))
    (is (eq :backgammon (game-result game)))
    (is (= 12 (game-score game)))))