gamao/src/checker-position.lisp

;;;; checker-position.lisp

(in-package #:gamao-impl)


#|
CHECKER-POSITION

A persistent data structure representing the checker position.  API:
type checker-position
make-checker-position => checker-position
update-checker-position checker-position location player checkers => checker-position
checker-position-checkers-at checker-position location player => checkers, owner
|#

(defstruct (checker-position (:constructor %make-checker-position (&optional (n 0)))
                             (:conc-name %checker-position-))
  "A persistent representation of a checker position.  The points are identified by numbers 1, 2, ..., 24; :BAR represents the bar and :OFF represents borne off checkers.
Creation: MAKE-CHECKER-POSITION
Updating: UPDATE-CHECKER-POSITION
Querying: CHECKER-POSITION-CHECKERS-AT
Rerooting for efficiency: COMMIT-CHECKER-POSITION
"
  n)

;; TODO specify initial position (?)
(defun make-checker-position ()
  "Return a fresh CHECKER-POSITION having zero checkers everywhere."
  (%make-checker-position 0))

(defun %checker-position-point-checker-byte (point)
  (byte 4 (1+ (* 5 (1- point)))))

(defun %checker-position-сolour-checker-byte (point)
  (* 5 (1- point)))

(defun %checker-position-encode-location (location player)
  (case location
    (:off (case player
            (:black (byte 4 128))
            (:white (byte 4 132))))
    (:bar (case player
            (:black (byte 4 120))
            (:white (byte 4 124))))
    (otherwise (%checker-position-point-checker-byte location))))

(defun %checker-position-decode-player-on-point (point checker-position)
  (if (logbitp (%checker-position-сolour-checker-byte point) (%checker-position-n checker-position))
      :black
      :white))

(defun checker-position-checkers-at (checker-position location player)
  "Return the number of checkers at LOCATION of CHECKER-POSITION and their owner.
   LOCATION: :BAR, :OFF, or a point represented by an integer between 1 and 24
   PLAYER: :BLACK, :WHITE or NIL
   If LOCATION is :BAR or :OFF, PLAYER must be non-null.
   If LOCATION is a point, and PLAYER is not null, return the number of checkers of specified player on the point.
   If LOCATION is a point, and PLAYER is null, return the number of checkers of any player on the point.
   If PLAYER is not null, it is returned as the second value.  Otherwise, it is the player occupying the point or NIL if no one occupies it."
  (let ((decoded-checkers (ldb (%checker-position-encode-location location player) (%checker-position-n checker-position))))
    (cond  ((zerop decoded-checkers) (values 0 player))
           ((member location '(:off :bar)) (values decoded-checkers player))
           (t (if (or (null player) (eq player (%checker-position-decode-player-on-point location checker-position)))
                  (values decoded-checkers (%checker-position-decode-player-on-point location checker-position))
                  (values 0 player))))))

(defun update-checker-position (checker-position location player checkers)
  "Return a new checker position differing from CHECKER-POSITION in that PLAYER has CHECKERS checkers on LOCATION."
  (let ((encoded-checkers-value (dpb checkers (%checker-position-encode-location location player) (%checker-position-n checker-position))))
    (%make-checker-position (case location
                              ((or :bar :off) encoded-checkers-value)
                              (otherwise (ecase player
                                           (:black (dpb 1  (byte 1 (%checker-position-сolour-checker-byte location)) encoded-checkers-value))
                                           (:white (dpb 0  (byte 1 (%checker-position-сolour-checker-byte location)) encoded-checkers-value))))))))

;; Does not perform any checks!  The caller must ensure that it's OK to actually move the checker.
(defun checker-position-move-checker (checker-position player from to)
  (let* ((checkers-at-start (checker-position-checkers-at checker-position from player))
         (checkers-at-finish (checker-position-checkers-at checker-position to player))
         (checker-removed (update-checker-position checker-position from player (1- checkers-at-start)))
         (checker-put (update-checker-position checker-removed to player (1+ checkers-at-finish))))
    checker-put))