Land of Lisp: Dice of Doom

dice-of-doom.lisp

(defparameter *num-players* 2)
(defparameter *max-dice* 3)
(defparameter *board-size* 3)
(defparameter *board-hexnum*
  (* *board-size* *board-size*))

(defun board-array (lst)
  "To allow faster access, create an array containing LST's contents."
  (make-array *board-hexnum* :initial-contents lst))

(defun gen-board ()
  "Generate an initial board."
  (board-array (loop for n below *board-hexnum*
                     collect (list (random *num-players*)
                                   (1+ (random *max-dice*))))))

(defun player-letter (n)
  "The player letter for player N."
  (code-char (+ 97 n)))

(defun draw-board (board)
  "Draw BOARD on-screen."
  (loop for y below *board-size*
        do (progn (fresh-line)
                  (loop repeat (- *board-size* y)
                        do (princ "  "))
                  (loop for x below *board-size*
                        for hex = (aref board
                                        (+ x
                                           (* *board-size* y)))
                        do (format t "~a-~a "
                                   (player-letter (car hex))
                                   (cadr hex))))))

(defun neighbors (pos)
  (let ((up (- pos *board-size*))
        (down (+ pos *board-size*)))
    (loop for p in (append (list up down)
                           (unless (zerop (mod pos *board-size*))
                             (list (1- up)
                                   (1- pos)))
                           (unless (zerop (mod (1+ pos) *board-size*))
                             (list (1+ pos)
                                   (1+ down))))
          when (and (>= p 0)
                    (< p *board-hexnum*))
          collect p)))

(defun board-attack (board player src dst dice)
  (board-array (loop for pos from 0
                     for hex across board
                     collect (cond
                               ((eq pos src)
                                (list player 1))
                               ((eq pos dst)
                                (list player (1- dice)))
                               (t
                                hex)))))

(defun attacking-moves (board cur-player spare-dice)
  (labels ((player (pos)
             (car (aref board pos)))
           (dice (pos)
             (cadr (aref board pos))))
    (mapcan (lambda (src)
              (when (eq (player src) cur-player)
                (mapcan (lambda (dst)
                          (when (and (not (eq (player dst)
                                              cur-player))
                                     (> (dice src)
                                        (dice dst)))
                            (list
                             (list (list src dst)
                                   (game-tree (board-attack board
                                                            cur-player
                                                            src
                                                            dst
                                                            (dice src))
                                              cur-player
                                              (+ spare-dice
                                                 (dice dst))
                                              nil)))))
                        (neighbors src))))
            (loop for n below *board-hexnum*
                  collect n))))

(defun add-passing-move (board player spare-dice first-move moves)
  (if first-move
      moves
      (cons (list nil
                  (game-tree (add-new-dice board
                                           player
                                           (1- spare-dice))
                             (mod (1+ player)
                                  *num-players*)
                             0
                             t))
            moves)))

(defun game-tree (board player spare-dice first-move)
  (list player
        board
        (add-passing-move board
                          player
                          spare-dice
                          first-move
                          (attacking-moves board player spare-dice))))

(defun rate-position (tree player)
  (let ((moves (caddr tree)))
    (if moves
        (apply (if (eq (car tree) player)
                   #'max
                   #'min)
               (get-ratings tree player))
        (let ((w (winners (cadr tree))))
          (if (member player w)
              (/ (length w))
              0)))))

(defun get-ratings (tree player)
  (mapcar (lambda (move)
            (rate-position (cadr move) player))
          (caddr tree)))

(defun print-info (tree)
  (fresh-line)
  (format t "current player: ~a" (player-letter (car tree)))
  (draw-board (cadr tree)))

(defun handle-computer (tree)
  (let ((ratings (get-ratings tree (car tree))))
    (cadr (nth (position (apply #'max ratings) ratings) (caddr tree)))))

(defun handle-human (tree)
  (fresh-line)
  (princ "choose your move:")
  (let ((moves (caddr tree)))
    (loop for move in moves
          for n from 1
          do (let ((action (car move)))
               (fresh-line)
               (format t "~a. " n)
               (if action
                   (format t "~a -> ~a" (car action) (cadr action))
                   (princ "end turn"))))
    (fresh-line)
    (cadr (nth (1- (read)) moves))))

(defun winners (board)
  (let* ((tally (loop for hex across board
                      collect (car hex)))
         (totals (mapcar (lambda (player)
                           (cons player (count player tally)))
                         (remove-duplicates tally)))
         (best (apply #'max (mapcar #'cdr totals))))
    (mapcar #'car (remove-if (lambda (x)
                               (not (eq (cdr x) best)))
                             totals))))

(defun announce-winner (board)
  (fresh-line)
  (let ((w (winners board)))
    (if (> (length w) 1)
        (format t "tie between ~a" (mapcar #'player-letter w))
        (format t "winner is ~a" (player-letter (car w))))))

;;; First pass at optimization; memoize functions that can be.

(let ((old-neighbors (symbol-function 'neighbors))
      (prev (make-hash-table)))
  (defun neighbors (pos)
    (or (gethash pos prev)
        (setf (gethash pos prev)
              (funcall old-neighbors pos)))))

(let ((old-game-tree (symbol-function 'game-tree))
      (prev (make-hash-table :test #'equalp)))
  (defun game-tree (&rest rest)
    (or (gethash rest prev)
        (setf (gethash rest prev)
              (apply old-game-tree rest)))))

(let ((old-rate-position (symbol-function 'rate-position))
      (prev (make-hash-table)))
  (defun rate-position (tree player)
    (let ((tab (gethash player prev)))
      (unless tab
        (setf tab (setf (gethash player prev) (make-hash-table))))
      (or (gethash tree tab)
          (setf (gethash tree tab)
                (funcall old-rate-position tree player))))))

;;; First pass at optimisation; tail call optimisation.

(defun add-new-dice (board player spare-dice)
  (labels ((f (lst n acc)
             (cond ((zerop n)
                    (append (reverse acc) lst))
                   ((null lst)
                    (reverse acc))
                   (t
                    (let ((curr-player (caar lst))
                          (curr-dice (cadar lst)))
                      (if (and (eq curr-player player)
                               (< curr-dice *max-dice*))
                          (f (cdr lst)
                             (1- n)
                             (cons (list curr-player (1+ curr-dice))
                                   acc))
                          (f (cdr lst)
                             n
                             (cons (car lst)
                                   acc))))))))
    (board-array (f (coerce board 'list)
                    spare-dice
                    ()))))

;;; Entry functions; start a game with one or other of these depending on the opponent you want.

(defun play-vs-computer (tree)
  (print-info tree)
  (cond ((null (caddr tree))
         (announce-winner (cadr tree)))
        ((zerop (car tree))
         (play-vs-computer (handle-human tree)))
        (t
         (play-vs-computer (handle-computer tree)))))

(defun play-vs-human (tree)
  (print-info tree)
  (if (caddr tree)
      (play-vs-human (handle-human tree))
      (announce-winner (cadr tree))))

Following along with the Dice of Doom example from the wonderful Land of Lisp - this implementation contains the optimisations contained in Chapter 15; memoization and tail call optimisation.