(require 'cl-ppcre)

(defvar *premature-end* nil)
(defvar *grid-size* 3)

(defparameter *board* (make-array '(3 3) :initial-element 'empty))

(defun show-board ()
  (dotimes (n *grid-size*) (format t "+---")) (format t "+~%")
    (dotimes (y *grid-size*)
      (format t "|")
      (dotimes (x *grid-size*)
	(format t " ~C |" (player-character (square-contents x y))))
    (format t "~%") (dotimes (n *grid-size*) (format t "+---")) (format t "+~%")))

(defun player-character (player)
  (cond ((equal player 'empty) #\Space)
	((equal player 'X) #\X)
	((equal player 'O) #\O)
	(t #\?)))

(defun read-turn (player)
  (format t "~C's turn (x,y):" (player-character player))
  (let ((response (read-line)))
    (cond ((string= response "q") 'quit)
	  (t (cl-ppcre:register-groups-bind
		 (input x y)
		 ("\(([1-3])[\s,]+([1-3])\)" response)
	       (list (- (parse-integer x) 1) (- (parse-integer y) 1)))))))

(defun square-available-p (x y)
  (equal (aref *board* x y) 'empty))

(defun square-contents (x y)
  (aref *board* x y))

(defun claim-square (player x y)
  ;;(format t "~a claims (~a, ~a)~%" (player-character player) x y)
  (setf (aref *board* x y) player))

(defun row-position->coords (row-n position)
  '(row-n position))

(defun column-position->coords (column-n position)
  '(position column-n))

(defun corner (x y)
  (let ((end (- *grid-size* 1)))
    (or (and (= x 0) (= y 0))
	(and (= x 0) (= y end))
	(and (= x end) (= y 0))
	(and (= x end) (= y end)))))

(defun diagonal-position->coords (direction)
  (cond ((equal direction 'left) '())
	((equal direction 'right) '())))

(defun take-turn (player)
  (let ((chosen-square (read-turn player)))
    (cond ((equal 'quit chosen-square) (setf *premature-end* t))
	  ((null chosen-square) (auto-turn player))
	  ((not (apply #'square-available-p chosen-square)) (take-turn player))
	  (t (apply #'claim-square (cons player chosen-square))))))

(defun random-turn (player)
  (let ((x (random *grid-size*))
	(y (random *grid-size*)))
    (cond ((square-available-p x y) (claim-square player x y))
	  (t (random-turn player)))))

(defun auto-turn (player)
  (let ((best-square '(0 0))
	(highest-rating 0))
    (dotimes (y *grid-size*)
      (dotimes (x *grid-size*)
	(if (square-available-p x y)
	    (let ((square-rating (rate-square player x y)))
	      ;;(format t "(~a, ~a): ~a for ~a~%" x y square-rating (player-character player))
	      (cond ((> square-rating highest-rating)
		     (progn
		       (setf best-square (list x y))
		       (setf highest-rating square-rating)))
		    ((and (= square-rating highest-rating) (= (random 3) 0))
		     (progn
		       (setf best-square (list x y))
		       (setf highest-rating square-rating))))))))
    (apply #'claim-square (cons player best-square))))

(defun rate-square (player x y)
  (let ((row (board-row y))
	(column (board-column x))
	(diagonals (remove-if #'null (board-diagonals x y)))
	(rating 0))
    (if (claimable-row-p row player) (incf rating 100))
    (if (claimable-column-p column player) (incf rating 100))
    (if (some #'(lambda (diagonal) (claimable-diagonal-p diagonal player)) diagonals) (incf rating 100))

    (if (claimable-row-p row (other-player player)) (incf rating 60))
    (if (claimable-column-p column (other-player player)) (incf rating 60))
    (if (some #'(lambda (diagonal) (claimable-diagonal-p diagonal (other-player player))) diagonals) (incf rating 60))

    (if (controlable-row-p row player) (incf rating 5))
    (if (controlable-column-p column player) (incf rating 5))
    (if (some #'(lambda (diagonal) (controlable-diagonal-p diagonal player)) diagonals) (incf rating 5))

    (if (controlable-row-p row (other-player player)) (incf rating 1))
    (if (controlable-column-p column (other-player player)) (incf rating 1))
    (if (some #'(lambda (diagonal) (controlable-diagonal-p diagonal (other-player player))) diagonals) (incf rating 1))

    (if (row-dead-p row player) (decf rating 3))
    (if (column-dead-p column player) (decf rating 3))

    (if (corner x y) (incf rating 1))
    
    rating))

;(defmacro dead (squares player)
;  `(and (find ,player ,squares)
;       (find (other-player ,player) ,squares)))

(defun row-dead-p (row player)
  (and (find player row)
       (find (other-player player) row)))

(defun column-dead-p (column player)
  (and (find player column)
       (find (other-player player) column)))

(defun diagonal-dead-p (diagonal player)
  (and (find player diagonal)
       (find (other-player player) diagonal)))

(defun controlable-row-p (row player)
  (and (>= (count player row) 1)
       (= (count 'empty row) (- *grid-size* 1))))

(defun controlable-column-p (column player)
  (and (>= (count player column) 1)
       (= (count 'empty column) (- *grid-size* 1))))

(defun controlable-diagonal-p (diagonal player)
  (and (>= (count player diagonal) 1)
       (= (count 'empty diagonal) (- *grid-size* 1))))

(defun claimable-row-p (row player)
  (and (= (count player row) (- *grid-size* 1))
       (= (count (other-player player) row) 0)))

(defun claimable-column-p (column player)
  (and (= (count player column) (- *grid-size* 1))
       (= (count (other-player player) column) 0)))

(defun claimable-diagonal-p (diagonal player)
  (and (= (count player diagonal) (- *grid-size* 1))
       (= (count (other-player player) diagonal) 0)))

(defun other-player (player)
  (cond ((equal player 'X) 'O)
	((equal player 'O) 'X)
	(t nil)))
    
(defun board->sequence ()
  (map 'list
       #'identity
       (make-array (array-total-size *board*)
		   :element-type (array-element-type *board*)
		   :displaced-to *board*)))

(defun select-sequence-elements (sequence element-indexes)
  (loop for i in element-indexes collect (elt sequence i)))

(defun range (count &optional (start 0) (step 1))
  (loop repeat count for i = start then (+ i step) collect i))
  
(defun board-row (y)
  (assert (< y *grid-size*))
  (let ((column-indexes (range *grid-size* y *grid-size*)))
    (select-sequence-elements (board->sequence) column-indexes)))

(defun board-column (x)
  (assert (< x *grid-size*))
  (setq x (* x *grid-size*))
  (let ((row-indexes (range *grid-size* x 1)))
    (select-sequence-elements (board->sequence) row-indexes)))

(defun board-diagonal (direction)
  (let ((left-positions (range *grid-size* 0 (+ *grid-size* 1)))
	(right-positions (range *grid-size* (- *grid-size* 1) (- *grid-size* 1))))
    (cond ((equal direction 'left) (select-sequence-elements (board->sequence) left-positions))
	  ((equal direction 'right) (select-sequence-elements (board->sequence) right-positions)))))

(defun board-diagonals (x y)
  (let* ((left-xs (range *grid-size* 0 1))
	 (left-ys (range *grid-size* 0 1))
	 (right-xs (range *grid-size* 0 1))
	 (right-ys (range *grid-size* (- *grid-size* 1) -1))
	 (left-diagonal (map 'list #'cons left-xs left-ys))
	 (right-diagonal (map 'list #'cons right-xs right-ys)))
    (list (if (= (position x left-xs) (position y left-ys)) (board-diagonal 'left) nil)
	  (if (= (position x right-xs) (position y right-ys)) (board-diagonal 'right) nil))))

(defun stalemate-p ()
  (= (count 'empty (board->sequence)) 1))

(defun all-equal (sequence &optional (test 'equal))
  (cond ((= (length sequence) 0) t)
	((= (length sequence) 1) t)
	((funcall test (elt sequence 0) (elt sequence 1)) (all-equal (cdr sequence) test))
	(t nil)))

(defun game-won-p (&optional (n 0))
  (cond ((>= n *grid-size*) nil)
	((and (not (equal (square-contents 0 n) 'empty)) (all-equal (board-row n))) (square-contents 0 n))
	((and (not (equal (square-contents n 0) 'empty)) (all-equal (board-column n))) (square-contents n 0))
	((and (not (equal (square-contents 0 0) 'empty)) (all-equal (board-diagonal 'left))) (square-contents 0 0))
	((and (not (equal (square-contents (- *grid-size* 1) 0) 'empty)) (all-equal (board-diagonal 'right))) (square-contents (- *grid-size* 1) 0))
	(t (game-won-p (+ n 1)))))

(defun play ()
  (format t "Noughts and Crosses~%===================~%~%Enter moves as co-ordinates separated by a ','. The grid is 1-3 on~%each side. Enter 'q' to quit. Enter anything else to have the computer~%take a turn.~%~%")

  (let ((current-player 'O))
    (setf *premature-end* nil)
    (loop
       until (or *premature-end* (stalemate-p) (game-won-p))
       do (show-board)
	 (take-turn current-player)
	 (setq current-player (other-player current-player))))
  (show-board)
  (cond ((game-won-p) (format t "~C wins!~%" (player-character (game-won-p))))
	((stalemate-p) (format t "Nobody won.~%"))
	(*premature-end* (format t "Quit.~%"))))