gamao-obsoleto/board.lisp

(in-package #:board)

#|

This is a low-level implementation of the backgammon board.  It supports basic operations but knows nothing of the rules of the game.

The board is not intended to be destructed.

The board has 24 points, the bar, and the bear-off zone.  We call them places.

Implementation

The board is implemented as an alist.  The car of each entry is either one of
the integers 1, ..., 24 used to identify a point, or one of the symbols BAR,
OFF.  The cdr depends on the type of the place.  If no association corresponds
to a place, it is assumed to have no checkers.

The integer ID of a point is its number from white's viewpoint.


|#


(deftype point-id () '(integer 1 24))

(deftype place () '(or point-id (member bar off)))

(defun pointp (place)
  "Given a place ID, return true if it is a point."
  (check-type place place)
  (not (member place '(bar off))))

(defun point-id (point-number player)
  "Return the point ID of PLAYER's POINT."
  (check-type point-number game:point)
  (check-type player game:player)
  (ecase player
    (:white point-number)
    (:black (- 25 point-number))))

(defun place (place-name player)
  "Return the place ID of PLAYER's place, where the place is a point number, BAR, or OFF."
  (case place-name
    ((bar off) place-name)
    (otherwise (point-id place-name player ))))

(defun point-number (point-id player)
  "Return PLAYER's point number corresponding to the ID POINT-ID."
  (check-type player game:player)
  (check-type point-id point-id)
  (ecase player
    (:white point-id)
    (:black (- 25 point-id))))

(deftype board () t)

(deftype checker-count () '(integer 0 15))

(defconstant bar 'bar)

(defconstant off 'off)

#|

There are three kinds of associations in the alist representing a board: a
point, where a point ID is followed by the number of checkers on it and their
colour; the bar, where the symbol BAR is followed by the number of white &
black checkers; and the bear-off zone, where the symbol OFF is followed by the
number of white & black checkers.  We define these kinds of associations as
list-based structures.

|#

(defstruct (board-point (:type list))
  "The list-based structure representing a point state: the point ID, the number of checkers on it, and if any, the owner of the checkers."
  (id 0 :type point-id)
  (checkers 0 :type checker-count)
  (whose nil :type (or null game:player)))

(defstruct (bar (:type list) :named)
  "The list-based structure representing the number of white & black checkers on the bar."
  (white 0 :type checker-count)
  (black 0 :type checker-count))

(defstruct (off (:type list) :named)
  "The list-based structure representing the number of white & black checkers in the bear-off zone"
  (white 0 :type checker-count)
  (black 0 :type checker-count))

#|

The following functions retrieve information about the board.

|#

(defun checkers-on-point (point-id board)
  "Given a point, return the number of checkers on it and their colour."
  (check-type point-id point-id)
  (check-type board board)
  (let ((p (assoc point-id board)))
    (if (null p)
        (values 0 nil)
        (values (board-point-checkers p)
                (board-point-whose p)))))

(defun checkers-on-bar (player board)
  "Return the number of PLAYER's checkers on the bar."
  (check-type player game:player)
  (check-type board board)
  (let ((b (assoc 'bar board)))
    (if (null b)
        0
        (ecase player
          (:white (bar-white b))
          (:black (bar-black b))))))

(defun checkers-off (player board)
  "Return the number of checkers PLAYER has borne off."
  (check-type player game:player)
  (check-type board board)
  (let ((borne-off (assoc 'off board)))
    (if (null borne-off)
        0
        (ecase player
          (:white (off-white borne-off))
          (:black (off-black borne-off))))))

(defun set-checkers-on-point (point-id n player board)
  "Return the board differing from BOARD in that the POINT-ID point has N PLAYER's checkers."
  (check-type n checker-count)
  (check-type player game:player)
  (check-type point-id point-id)
  (check-type board board)
  (cons (make-board-point :id point-id
                          :checkers n
                          :whose (if (zerop n) nil player))
        board))

(defun set-checkers-on-bar (n player board)
  "Return the board differing from BOARD in that PLAYER has N checkers on the bar."
  (check-type n checker-count)
  (check-type player game:player)
  (check-type board board)
  (let* ((white (checkers-on-bar :white board))
         (black (checkers-on-bar :black board)))
    (cons (make-bar :white (ecase player
                             (:white n)
                             (:black white))
                    :black (ecase player
                             (:white black)
                             (:black n)))
          board)))

(defun set-checkers-off (n player board)
  "Return the board differing from BOARD in that PLAYER has borne off N checkers."
  (check-type n checker-count)
  (check-type player game:player)
  (check-type board board)
  (let* ((white (checkers-off :white board))
         (black (checkers-off :black board)))
    (cons (make-off :white (ecase player
                             (:white n)
                             (:black white))
                    :black (ecase player
                             (:white black)
                             (:black n)))
          board)))

(defun has-checkers-on-p (place player board)
  (check-type place place)
  (check-type player game:player)
  (check-type board board)
  (case place
    (bar (plusp (checkers-on-bar player board)))
    (off (plusp (checkers-off player board)))
    (t (multiple-value-bind (checkers whose) (checkers-on-point place board)
         (and (eql whose player)
              (plusp checkers))))))

(defun highest (player board)
  (loop for p from 24 downto 1
        when (has-checkers-on-p (point-id p player) player board)
        do (return p)
        finally (return 0)))

(defun loss (player board)
  (cond ((has-checkers-on-p off player board) 1)
        ((or (has-checkers-on-p bar player board)
             (>= (highest player board) 19))
         3)
        (t 2)))

(defun move-checker (from to player board)
  "Returns a new bord with the checker of the player moved from FROM to TO.  If there are opponent's checkers on TO, they go to the bar.  The validity of the move is NOT checked."
  (let* ((remove-checker (case from
                           (bar (set-checkers-on-bar (1- (checkers-on-bar player board))
                                                     player
                                                     board))
                           (otherwise (set-checkers-on-point from
                                                             (1- (checkers-on-point from board))
                                                             player
                                                             board))))
         (put-checker (case to
                        (off (set-checkers-off (1+ (checkers-off player board))
                                               player
                                               remove-checker))
                        (otherwise (multiple-value-bind (checkers-on-destination whose) (checkers-on-point to board)
                                     (if (or (eql whose player) (null whose))
                                         (set-checkers-on-point to
                                                                (1+ checkers-on-destination)
                                                                player
                                                                remove-checker)
                                         (let ((opponent (game:opponent player)))
                                           (set-checkers-on-point to
                                                                  1
                                                                  player
                                                                  (set-checkers-on-bar (+ (checkers-on-bar opponent board)
                                                                                          checkers-on-destination)
                                                                                       opponent
                                                                                       remove-checker)))))))))
    put-checker))

(defun make-empty-board ()
  '())


(defparameter *initial-arrangement* '((24 2)
                                      (13 5)
                                      (8 3)
                                      (6 5)))

(defun make-initial-board ()
  (list* (make-bar)
         (make-off)
         (loop for point from 1 to 24
               collect (loop for player in '(:white :black)
                             for n = (second (assoc (point-number point player) *initial-arrangement*))
                             when n do (return (make-board-point :id point :checkers n :whose player))
                             finally (return (make-board-point :id point :checkers 0))))))