gamao-obsoleto/game.lisp

(in-package #:game)

#|

CHECKER PLAY

The rules of backgammon are partly incorporated in the function POSSIBLE-MOVES.
It returns a forest of possible moves as a list.  The car of each element is
the first move, the cdr is the tree of possible continuations.

|#

(deftype die-pips () '(integer 1 6))

(deftype origin () '(or point (eql board:bar)))

(defun destination (from pips player)
  "Return the place where PLAYER's checker would land starting from FROM and travelling PIPS.  The second value is T if the move is shorter than DISTANCE (possible when bearing off)."
  (check-type from origin)
  (check-type pips die-pips)
  (check-type player player)
  (if (eql from board:bar)
      (board:point-id (- 25 pips) player)
      (let ((point-number (board:point-number from player)))
        (if (> point-number pips)
            (board:point-id (- point-number pips) player)
            board:off))))

(defun openp (point player board)
  (check-type player player)
  (check-type point point)
  (check-type board board::board)
  (multiple-value-bind (checkers whose) (board:checkers-on-point point board)
    (not (and (eql whose (opponent player))
              (>= checkers 2)))))

(defun can-move-p (from pips player board)
  (check-type from origin)
  (check-type pips die-pips)
  (check-type player player)
  (and
    ;; you must have checkers where you want to move them from
    (board:has-checkers-on-p from player board)
    ;; if you've got checkers on the bar, you must enter them first
    (or (not (board:has-checkers-on-p board:bar player board))
        (eql from board:bar))
    ;; now let's check the destination
    (let ((to (destination from pips player)))
      ;; either you go to an open point
      (or (and (board:pointp to) (openp to player board))
          ;; or else you want to bear off, but in this case
          (and (eql to board:off)
               (let ((highest (board:highest player board)))
                 ;; all your checkers must be at home and
                 (and (<= highest 6)
                      ;; you either use up all the pips
                      (or (= (board:point-number from player) pips)
                          ;; or bear off from the highest point
                          (eql (board:point-id highest player) from)))))))))


(defmacro do-origins ((var &optional result) &body body)
  `(do ((,var board:bar (if (eql ,var board:bar)
                            24
                            (1- ,var))))
       ((eql ,var 0) ,result)
       ,@body))

(defparameter +number-of-checkers+ 15)

(defstruct (checker-move (:type list))
  (pips 1 :type die-pips)
  (from 1 :type origin)
  (to 1)
  (end? nil :type boolean))

(defun possible-single-moves (pips player board)
  (let ((moves '()))
    (do-origins (from moves)
      (when (can-move-p from pips player board)
        (let* ((destination (destination from pips player))
               (end? (and (eql destination board:off)
                          (= (board:checkers-off player board)
                             (1- +number-of-checkers+)))))
          (push (make-checker-move :pips pips
                                   :from from
                                   :to destination
                                   :end? end?)
                moves))))))

(defun possible-moves* (dice player board)
  (cond ((endp dice) '())
        ((endp (rest dice)) (mapcar #'list (possible-single-moves (first dice) player board)))
        (t (loop with new-board
                 for move in (possible-single-moves (first dice) player board)
                 for from = (checker-move-from move)
                 for to = (checker-move-to move)
                 for end? = (checker-move-end? move)
                 if end?
                 collect (list move)
                 else
                 do (setf new-board (board:move-checker from to player board))
                 collect (cons move (possible-moves* (rest dice) player new-board))))))

(defun possible-moves-different-dice (die1 die2 player board)
  (or (append (possible-moves* (list die1 die2) player board)
              (possible-moves* (list die2 die1) player board))
      (possible-moves* (list die1) player board)
      (possible-moves* (list die2) player board)))

(defun possible-moves-doublet (die player board)
  (loop for k from 4 downto 1
        for moves = (possible-moves* (make-list k :initial-element die) player board)
        when moves do (return moves)
        finally (return '())))

(defun position-possible-moves (die1 die2 player board)
  (check-type die1 die-pips)
  (check-type die2 die-pips)
  (check-type player player)
  (check-type board board::board)
  (if (/= die1 die2)
      (possible-moves-different-dice die1 die2 player board)
      (possible-moves-doublet die1 player board)))

(defun remaining-moves (moves possible-moves)
  (if (endp moves)
      possible-moves
      (remaining-moves (rest moves) (rest (assoc (first moves) possible-moves :test #'equal)))))

(defun full-move-p (moves possible-moves)
  (cond ((endp moves) (endp possible-moves))
        ((endp possible-moves) t)
        (t (full-move-p (rest moves) (rest (assoc (first moves) possible-moves
                                                  :test #'equal))))))

(defun check-next-move (from pips possible-moves &optional partial-moves)
  (if (endp partial-moves)
      (flet ((this-move-p (move)
               (and (eql (checker-move-from move) from)
                    (eql (checker-move-pips move) pips))))
        (find-if #'this-move-p (mapcar #'first possible-moves)))
      (check-next-move from
                       pips
                       (rest (assoc (first partial-moves) possible-moves :test #'equal))
                       (rest partial-moves))))

(defclass game ()
  ((initial-throws :reader initial-throws :initform '())
   (dice-no :reader dice-no :initform 0)
   (moves :reader moves :initform '())
   (partial-moves :reader partial-moves :initform '())
   (board :reader board :initform (board:make-initial-board))
   (partial-board :reader partial-board)
   (cube :reader cube :initarg :cube :initform nil)
   (cube-owner :reader cube-owner :initform nil)
   (dice :reader dice :initform '())
   (rest-dice :reader rest-dice :initform '())
   (turn :reader turn :initform nil)
   (is-doubling :reader is-doubling :initform '())
   (winner :reader winner :initform nil)
   (result :reader result :initform nil)
   (jacoby :reader jacoby :initarg :jacoby :initform t)
   (session :reader session :initarg :session :initform nil)
   (possible-moves% :reader possible-moves :initform '())))

(defmethod initialize-instance :after ((game game) &key &allow-other-keys)
  (setf (slot-value game 'partial-board) (board game)))

(defun random-dice ()
  (let ((dice (random 36)))
    (multiple-value-bind (d1 d2) (floor dice 6)
      (list (1+ d1) (1+ d2)))))

(defun dices-rest-dice (dice)
  (if (= (first dice) (second dice))
      (append dice dice)
      dice))

(defgeneric game:roll-dice (game))

(defmethod game:roll-dice ((game game))
  (with-slots (dice rest-dice dice-no) game
    (setf dice (random-dice)
          rest-dice (dices-rest-dice dice))
    (incf dice-no))
  game)

(defmethod roll-dice :after ((game game))
  (setf (slot-value game 'possible-moves%) (position-possible-moves (first (dice game))
                                                                    (second (dice game))
                                                                    (turn game)
                                                                    (board game))))

(defgeneric set-turn (game))

(defmethod set-turn ((game game))
  (with-slots (turn rest-dice dice-no) game
    (setf turn (if (> (first (dice game))
                      (second (dice game)))
                   :white
                   :black)
          rest-dice (dice game)
          dice-no 1))
  game)

(defmethod set-turn :after ((game game))
  (setf (slot-value game 'possible-moves%) (position-possible-moves (first (dice game))
                                                                         (second (dice game))
                                                                         (turn game)
                                                                         (board game))))
(defgeneric move-checker (from pips game))

;;; Generally, we avoid enforcing any checks.  Maybe this check-next-move should be removed as well?  The caller should take care of that.
(defmethod move-checker (from pips (game game))
  (let ((move (check-next-move from pips (possible-moves game) (partial-moves game))))
    (when (null move)
      (error "Cannot move from ~A by ~A." from pips))
    (with-slots (partial-moves partial-board rest-dice) game
      (setf partial-moves (append partial-moves (list move))
            partial-board (board:move-checker from (checker-move-to move) (turn game) partial-board)
            rest-dice (remove pips rest-dice :count 1)))
    game))

(defgeneric set-winner (player game reason))

(defmethod set-winner (player (game game) reason)
  (check-type player player)
  (with-slots (winner result) game
    (setf winner player
          result (ecase reason
                   (:completed (ecase (board:loss (opponent player) (board game))
                                 (1 :single-game)
                                 (2 :gammon)
                                 (3 :backgammon)))
                   (:dropped-double :dropped-double)))))

(defun game-score (game)
  (let* ((cube (or (cube game) 1))
         (jacoby? (jacoby game))
         (value (ecase (result game)
                  (:single-game cube)
                  (:gammon (if (and jacoby? (= cube 1))
                               1
                               (* cube 2)))
                  (:backgammon (if (and jacoby? (= cube 1))
                                   1
                                   (* cube 3)))
                  (:dropped-double cube)
                  ((nil) 0))))
    (cond ((zerop value) 0)
          ((player= (winner game) :white) value)
          (t (- value)))))

(defun games-score (games)
  (loop for game in games
        for score = (game-score game)
        when (plusp score) sum score into white-score
        when (minusp score) sum (- score) into black-score
        finally (return (list white-score black-score))))

(defun score (session)
  (games-score (games session)))

(defgeneric finish-move (game))

(defmethod finish-move ((game game))
  (let ((end? (some #'checker-move-end? (partial-moves game))))
    (with-slots (moves partial-moves board) game
      (push partial-moves moves)
      (setf partial-moves '()
            board (partial-board game)))
    (if end?
        (set-winner (turn game) game)))
  game)

(defgeneric opponents-turn (game))

(defmethod opponents-turn ((game game))
  (with-slots (turn dice) game
    (setf turn (opponent turn)
          dice '())
    game))

(defgeneric undo-move (game))

(defmethod undo-move ((game game))
  (unless (null (partial-moves game))
    (let ((player (turn game)))
      (with-slots (partial-moves partial-board rest-dice) game
        (setf partial-moves (butlast partial-moves)
              partial-board (board game)
              rest-dice (dices-rest-dice (dice game)))
        (dolist (move partial-moves)
          (setf partial-board (board:move-checker (checker-move-from move)
                                                  (checker-move-to move)
                                                  player 
                                                  partial-board))
          (setf rest-dice (remove (checker-move-pips move) rest-dice :count 1))))
      game)))

(defgeneric offer-double (game))

(defmethod offer-double ((game game))
  (with-slots (moves is-doubling) game
    (setf is-doubling (turn game))
    (push :double moves)))

(defgeneric accept-double (game))

(defmethod accept-double ((game game))
  (with-slots (moves cube cube-owner is-doubling) game
    (setf cube (* 2 cube)
          cube-owner (turn game)
          is-doubling nil)
    (push :accept moves)))

(defgeneric refuse-double (game))

(defmethod refuse-double ((game game))
  (with-slots (moves is-doubling) game
    (setf is-doubling nil)
    (push :drop moves)))


(defparameter *default-game-class* 'game)
(defparameter *default-match-class* 'match)
(defparameter *default-money-session-class* 'money-session)

(defclass session ()
  ((games :reader games :initform '())
   (jacobyp :reader jacobyp :initarg :jacoby)
   (game-class :reader game-class :initarg :game-class :initform *default-game-class*)
   (cube :reader cube :initarg :cube)))

(defclass match (session)
  ((games :reader games :initform '())
   (limit :reader limit :initarg :limit)
   (jacobyp :reader jacobyp :initarg :jacoby :initform nil)
   (crawfordp :reader crawfordp :initarg :crawford :initform t)
   (crawford-game :reader crawford-game :initform nil)))

(defclass money-session (session)
  ((jacobyp :reader jacobyp :initarg :jacoby :initform t)
   (continuation-query :reader continuation-query :initarg :continuation-query :initform (constantly t))
   (finished? :initform nil)))

(defgeneric finished-p (session))

(defmethod finished-p ((session money-session))
  (slot-value session 'finished?))

(defmethod finished-p ((match match))
  (>= (apply #'max (score match)) (limit match)))

(defun make-match (limit &key (class *default-match-class*) (game-class *default-game-class*))
  (make-instance class
                 :limit limit
                 :game-class game-class))

(defun make-money-session (continuation-query &key (class *default-money-session-class*) (game-class *default-game-class*) )
  (make-instance class
                 :continuation-query continuation-query
                 :game-class game-class))

(defun game (session)
  (first (games session)))

(defgeneric opponent-can-double-p (session))

(defmethod opponent-can-double-p ((game game))
  (and (not (null (cube game)))
       (not (player-equal (turn game)
                          (cube-owner game)))))

(defmethod opponent-can-double-p ((session money-session))
  (opponent-can-double-p (game session)))

(defun crawford-game-p (game)
  (let ((session (session game)))
    (and (typep session 'match)
         (eql game (crawford-game session)))))

(defun points (player session)
  (let ((score (score session)))
    (ecase player
      (:white (first score))
      (:black (second score)))))

(defmethod opponent-can-double-p ((match match))
  (let ((game (game match)))
    (and (cube match)
         (null (winner game))
         (not (crawford-game-p game))
         (< (+ (points (opponent (turn game)) match)
               (cube game))
            (limit match))
         (opponent-can-double-p game))))

(defgeneric start-new-game (session))

(defmethod start-new-game ((session money-session))
  (let ((game (make-instance (game-class session)
                             :session session
                             :cube (and (cube session) 1)
                             :jacoby (jacobyp session))))
    (push game (slot-value session 'games))))

(defun next-game-crawford-p (match)
  (let ((games (games match))
        (limit (limit match)))
    (and (cube match)
         (>= (length (games match)) 1)
         (= (apply #'max (games-score games)) (1- limit))
         (< (apply #'max (games-score (rest games))) (1- limit)))))

(defmethod start-new-game ((match match))
  (let ((crawford? (next-game-crawford-p match)))
    (let ((game (make-instance (game-class match)
                               :session match
                               :cube (and (cube match)
                                          (not crawford?)
                                          1)
                               :jacoby (jacobyp match))))
      (push game (slot-value match 'games))
      (when crawford?
        (setf (slot-value match 'crawford-game) game)))))

(defmethod winner ((match match))
  (let ((score (score match))
        (limit (limit match)))
    (cond ((>= (first score) limit) :white)
          ((>= (second score) limit) :black)
          (t nil))))