Tic Tac Toe

;;;;
;;;; Written: John Thingstad 27/01-2007
;;;; Algorithm for computer by Nils Holm
;;;;

(defconstant +element-state+ '(#\- #\O #\X))
(defconstant +player-state+ '(#\X #\O))

(defun element-state-p (element) 
  (member element +element-state+))

(defun player-state-p (player)
  (member player +player-state+))

(defun board-coordinate-p (list)
  (and (= (length list) 2)
       (every (lambda (element) 
                (typep element '(integer 0 2)))
                list)))

(defun tictactoe-board-p (board)
  (and (= (array-rank board) 2)
       (equal (array-dimensions board) '(3 3))
       (eq (array-element-type board) 'base-char)))

(deftype element-state () `(and base-char (satisfies element-state-p)))
(deftype player-state () `(and base-char (satisfies player-state-p)))
(deftype board-coordinate () `(and list (satisfies board-coordinate-p)))
(deftype tictactoe-board () `(and simple-array (satisfies tictactoe-board-p)))

(defun make-board ()
  (make-array '(3 3) 
              :element-type 'element-state
              :initial-contents '((#\- #\- #\-) 
                                  (#\- #\- #\-)
                                  (#\- #\- #\-))))

(defun print-board (board)
  (check-type board tictactoe-board)
  (fresh-line)
  (dotimes (j 3)
    (dotimes (i 3)
      (write-char (aref board j i))
      (write-char #\Space))
    (terpri))
  (terpri)
  (values))

(defun set-board (board coord state)
  (check-type board tictactoe-board)
  (check-type coord board-coordinate)
  (check-type state player-state)
  (destructuring-bind (row col) coord
    (setf (aref board row col) state)))

(defun get-board (board coord)
  (check-type board tictactoe-board)
  (check-type coord board-coordinate)
  (destructuring-bind (row col) coord
    (aref board row col)))

(defconstant +rule-list+
  '(((#\- #\O #\O)  (#\O #\O #\O)) 
    ((#\O #\- #\O)  (#\O #\O #\O)) 
    ((#\O #\O #\-)  (#\O #\O #\O)) 
    ((#\- #\X #\X)  (#\O #\X #\X)) 
    ((#\X #\- #\X)  (#\X #\O #\X)) 
    ((#\X #\X #\-)  (#\X #\X #\O)) 
    ((#\- #\X #\-)  (#\O #\X #\-)) 
    ((#\- #\- #\X)  (#\- #\O #\X)) 
    ((#\X #\- #\-)  (#\X #\O #\-)) 
    ((#\- #\X #\O)  (#\O #\X #\O)) 
    ((#\- #\O #\X)  (#\O #\O #\X)) 
    ((#\X #\- #\O)  (#\X #\O #\O)) 
    ((#\X #\O #\-)  (#\X #\O #\O)) 
    ((#\O #\- #\X)  (#\O #\O #\X)) 
    ((#\O #\X #\-)  (#\O #\X #\O)) 
    ((#\- #\- #\O)  (#\O #\- #\O)) 
    ((#\- #\O #\-)  (#\O #\O #\-)) 
    ((#\O #\- #\-)  (#\O #\- #\O)) 
    ((#\- #\- #\-)  (#\- #\O #\-))))

(defun match-row (board f1 f2 f3 rule)
  (destructuring-bind (pattern substitution) rule
    (destructuring-bind (v1 v2 v3) pattern
      (if (and (char= (row-major-aref board f1) v1)
               (char= (row-major-aref board f2) v2)
               (char= (row-major-aref board f3) v3))
          (destructuring-bind (s1 s2 s3) substitution
            (setf (row-major-aref board f1) s1)
            (setf (row-major-aref board f2) s2)
            (setf (row-major-aref board f3) s3)
            substitution)
        nil))))

(defun try-moves (board rules)
  (dolist (rule rules)
    (let ((move (or (match-row board 0 4 8 rule)
                    (match-row board 2 4 6 rule)
                    (match-row board 0 1 2 rule)
                    (match-row board 3 4 5 rule)
                    (match-row board 6 7 8 rule) 
                    (match-row board 0 3 6 rule)
                    (match-row board 1 4 7 rule)
                    (match-row board 2 5 8 rule))))
      (when move (return-from try-moves move)))))

(defun play-move (board)
  (check-type board tictactoe-board)
  (if (char= (get-board board '(1 1)) #\-)
      (set-board board '(1 1) #\O)
    (try-moves board +rule-list+)))

(defun three-row (board f1 f2 f3)
  (if (char= (row-major-aref board f1)
             (row-major-aref board f2)
             (row-major-aref board f3))
      (if (not (char= (row-major-aref board f1) #\-))
          (row-major-aref board f1)
        nil)
    nil))

(defun game-won (board)
  (or
   (three-row board 0 4 8)
   (three-row board 2 4 6)
   (three-row board 0 1 2)
   (three-row board 3 4 5)
   (three-row board 6 7 8) 
   (three-row board 0 3 6) 
   (three-row board 1 4 7) 
   (three-row board 2 5 8)))

(defun intro ()
  (fresh-line)
  (write-line "Welcome to the game Tic Tac Toe")
  (write-line "To play a move select a number on the grid")
  (terpri)
  (write-line "    1 2 3 ")
  (write-line " A  - - - ")
  (write-line " B  - - - ")
  (write-line " C  - - - ")
  (terpri))

(defun available-squares (board)
  (let (squares)
    (dotimes (j 3)
      (dotimes (i 3)
        (when (char= (aref board j i) #\-)
          (push (list j  i) squares))))
    squares))

(defun calculate-coordinate (string)
  (let ((row (- (char-code (aref string 0)) (char-code #\A)))
        (col (- (char-code (aref string 1)) (char-code #\0) 1)))
    (list row col)))
   
(defun prompt-move(positions &optional (prompt "Enter move: "))
  (fresh-line)
  (write-string prompt)
  (force-output)
  (clear-input)
  (let ((string (read-line)))
    (unless (and (= (length string) 2)
                 (member (aref string 0) '(#\A #\B #\C))
                 (member (aref string 1) '(#\1 #\2 #\3)))
      (return-from prompt-move 
        (prompt-move positions "Error! [A-C][1-3]: ")))
    (unless (member (calculate-coordinate string) positions :test #'equal)
      (return-from prompt-move 
        (prompt-move positions "Occupied! Enter move: ")))
    (terpri)
    (calculate-coordinate string)))

(defun print-result (result)
  (cond 
   ((null result) 
    (write-line "It's a draw!"))
   ((char= result #\X)
    (write-line "You won!"))
   ((char= result #\O)
    (write-line "I Won!"))))

(defun tic-tac-toe ()
  (let ((board (make-board)))
    (intro)
    (loop
     (set-board board (prompt-move (available-squares board)) #\X)
     (when (or (game-won board) (null (available-squares board)))
       (print-board board)
       (print-result (game-won board))
       (return-from tic-tac-toe (values)))
     (play-move board)
     (print-board board)
     (when (or (game-won board) (null (available-squares board)))
       (print-result (game-won board))
       (return-from tic-tac-toe (values))))))