(in-package :atoms)

(defun score-better-p (this that)
  (or (eq this :win)
      (eq that :lose)
      (and (not (eq this :lose))
	   (not (eq that :win))
	   (> this that))))

(defun invert-score (this)
  (case this
    (:win :lose)
    (:lose :win)
    (t (- this))))

(defparameter *plies* 2)

(defun make-board-connectivity-map (width height)
  (let ((map (make-array (* width height)
			 :element-type 'list
			 :initial-element nil)))
    (flet ((index (i j) (+ (* j width) i)))
      (dotimes (j height)
	(dotimes (i width)
	  (setf (aref map (index i j))
		(nconc (and (> j 0) (list (index i (1- j))))
		       (and (> i 0) (list (index (1- i) j)))
		       (and (< i (1- width)) (list (index (1+ i) j)))
		       (and (< j (1- height)) (list (index i (1+ j))))))))
      map)))

(deftype octet () '(unsigned-byte 8))

(defun make-critical-count-map (conn-map)
  (make-array (length conn-map)
	      :element-type 'octet
	      :initial-contents (map 'list #'length conn-map)))

(defun make-simple-board (size)
  (make-array size
	      :element-type 'octet
	      :initial-element 0))

(defun copy-vector (vector)
  (make-array (length vector)
	      :element-type (array-element-type vector)
	      :initial-contents vector))

(defun simple-score (who counts owners)
  (reduce #'+ (mapcar (lambda (count owner)
			(if (= owner who) count 0))
		      counts owners)))

(defun make-checklist (size)
  (make-array size :element-type 'fixnum :fill-pointer 0))

(defclass robot-state ()
  ((n-players :type octet :reader robot-n-players :initarg :n-players)
   (me :type octet :reader robot-me :initarg :me)
   (size :type fixnum :reader robot-size :initarg :size)
   (conn-map :type (vector list *) :reader robot-conn-map :initarg :conn-map)
   (crit-map :type (vector octet *)
	     :reader robot-crit-map
	     :initarg :crit-map)
   (checklist-a :type (vector fixnum *)
		:reader robot-checklist-a
		:initarg :checklist-a)
   (checklist-b :type (vector fixnum *)
		:reader robot-checklist-b
		:initarg :checklist-b)
   (scores :type (vector fixnum *) :reader robot-scores :initarg :scores)
   (seen :type bit-vector :reader robot-seen :initarg :seen)))

(defclass robot-position ()
  ((who :type octet :reader robot-who :initarg :who)
   (counts :type (vector octet *) :reader robot-counts :initarg :counts)
   (owners :type (vector octet *) :reader robot-owners :initarg :owners)))

(defun make-robot-state (game player)
  (let* ((grid (game-grid game))
	 (width (array-dimension grid 1))
	 (height (array-dimension grid 0))
	 (size (* width height))
	 (n-players (length (game-players game)))
	 (conn-map (make-board-connectivity-map width height)))
    (make-instance 'robot-state
		   :me (1+ (position player (game-players game)))
		   :n-players n-players
		   :size size
		   :conn-map conn-map
		   :crit-map (make-critical-count-map conn-map)
		   :scores (make-array (1+ n-players) :element-type 'fixnum)
		   :checklist-a (make-checklist size)
		   :checklist-b (make-checklist size)
		   :seen (make-array size :element-type 'bit))))

(defun make-robot-position (who counts owners)
  (make-instance 'robot-position
		 :who who
		 :counts counts
		 :owners owners))

(defun make-initial-robot-position (state game)
  (let* ((size (robot-size state))
	 (grid (game-grid game))
	 (counts (make-simple-board size))
	 (owners (make-simple-board size)))

    (dotimes (i size)
      (let ((cell (row-major-aref grid i)))
	(setf (aref counts i) (cell-count cell)
	      (aref owners i) (let ((owner (cell-owner cell)))
				(if owner (1+ owner) 0)))))

    (make-robot-position (robot-me state) counts owners)))

(defclass robot-player (player)
  ((robot-state :type robot-state :reader robot-player-state)))
(setf (player-type-name 'robot-player) "Robot")

(defun robot-update-scores (state counts owners)
  (let ((scores (robot-scores state))
	(n-players (robot-n-players state))
	(size (robot-size state)))
    (dotimes (i (1+ n-players)) (setf (aref scores i) 0))
    (dotimes (i size) (incf (aref scores (aref owners i)) (aref counts i)))))

(defun robot-try-move (state position move)
  (let ((conn-map (robot-conn-map state))
	(crit-map (robot-crit-map state))
	(n-players (robot-n-players state))
	(size (robot-size state))
	(seen (robot-seen state))
	(checklist (robot-checklist-a state))
	(next-checklist (robot-checklist-b state))
	(who (robot-who position))
	(scores (robot-scores state))
	(owners (copy-vector (robot-owners position)))
	(counts (copy-vector (robot-counts position))))

    (let ((occupier (aref owners move)))
      (unless (or (zerop occupier) (= occupier who))
	(return-from robot-try-move nil)))

    (block update-board
      (setf (aref owners move) who)
      (unless (>= (incf (aref counts move))
		  (aref crit-map move))
	(return-from update-board))

      (setf (fill-pointer checklist) 0)
      (vector-push move checklist)
      (let ((opponents (count-if (lambda (own)
				   (and (plusp own) (/= own who)))
				 owners)))
	(loop
	  (when (or (zerop (fill-pointer checklist))
		    (zerop opponents))
	    (return-from update-board))
	  (setf (fill-pointer next-checklist) 0)
	  (dotimes (i size) (setf (bit seen i) 0))
	  (dotimes (i (fill-pointer checklist))
	    (let* ((pos (aref checklist i))
		   (crit (aref crit-map pos)))
	      (multiple-value-bind (dist left) (floor (aref counts pos) crit)
		(setf (aref counts pos) left)
		(when (zerop left)
		  (setf (aref owners pos) 0))
		(dolist (neigh (aref conn-map pos))
		  (let ((old-owner (aref owners neigh)))
		    (unless (= old-owner who)
		      (unless (zerop old-owner) (decf opponents))
		      (setf (aref owners neigh) who))
		    (when (and (>= (incf (aref counts neigh) dist)
				   (aref crit-map neigh))
			       (zerop (bit seen neigh)))
		      (vector-push neigh next-checklist)
		      (setf (bit seen neigh) 1)))))))
	  (rotatef checklist next-checklist))))

    (robot-update-scores state counts owners)
    (make-robot-position (do ((i (1+ (mod who n-players))
				 (1+ (mod i n-players))))
			     ((plusp (aref scores i)) i))
			 counts owners)))

(defun simple-rating (state position)
  (declare (ignore position))
  (let* ((n-players (robot-n-players state))
	 (scores (robot-scores state))
	 (me (robot-me state))
	 (total (reduce #'+ scores))
	 (mine (aref scores me)))
    (cond ((and (zerop mine) (>= total me)) :lose)
	  ((and (= mine total) (>= total n-players)) :win)
	  (t (- (* 2 mine) total)))))

(defparameter *robot-n-plies* 2)

(defun robot-choose-move (state game)
  (let ((me (robot-me state))
	(size (robot-size state)))
    (labels ((walk (position depth alpha beta)
	       (let ((who (robot-who position)))

		 #+debug
		 (format t ";; walk; who = ~A; depth remaining = ~A~%"
			 who depth)

		 (let ((rating (simple-rating state position)))
		   (case rating
		     ((:win :lose)
		      #+debug
		      (format t ";;   final position ~A~%" rating)
		      (return-from walk (values rating nil))))
		   (when (zerop depth)
		     #+debug
		     (format t ";;   bottomed out; rating = ~A~%" rating)
		     (return-from walk (values rating nil))))

		 (if (= who me)
		     (let ((best-move nil))
		       (dotimes (move size)
			 #+debug
			 (format t ";;   try my move ~A~%"
				 (multiple-value-list
				  (floor move
					 (array-dimension (game-grid game)
							  1))))
			 (let ((next-pos (robot-try-move state
							 position
							 move)))
			   (when next-pos
			     (let ((score (walk next-pos
						(1- depth)
						alpha beta)))
			       (when (score-better-p score alpha)
				 #+debug
				 (format t ";;   best move so far~%")
				 (setf best-move move
				       alpha score))
			       (when (score-better-p alpha beta)
				 (return))))))
		       (values alpha best-move))
		     (let ((best-move nil))
		       (dotimes (move size)
			 #+debug
			 (format t ";;   try opponent #~A move ~A~%"
				 who
				 (multiple-value-list
				  (floor move
					 (array-dimension (game-grid game)
							  1))))
			 (let ((next-pos (robot-try-move state
							 position
							 move)))
			   (when next-pos
			     (let ((score (walk next-pos
						(1- depth)
						alpha beta)))
			       (when (score-better-p beta score)
				 #+debug
				 (format t ";;   best opponent move so far~%")
				 (setf best-move move
				       beta score))
			       (when (score-better-p alpha beta)
				 (return))))))
		       (values beta best-move))))))
      (let ((position (make-initial-robot-position state game)))
	(robot-update-scores state
			     (robot-counts position)
			     (robot-owners position))
	(multiple-value-bind (rating move)
	    (walk position *robot-n-plies* :lose :win)
	  (declare (ignore rating))
	  move)))))

(defun robot-move (game player)
  (let* ((state (robot-player-state player))
	 (move (robot-choose-move state game))
	 (grid (game-grid game))
	 (width (array-dimension grid 1)))
    (multiple-value-bind (j i) (floor move width)
      (play-cell game player i j))))

(defun stupid-robot-move (game player)
  (let* ((state (robot-player-state player))
	 (grid (game-grid game))
	 (width (array-dimension grid 1))
	 (height (array-dimension grid 0))
	 (moves (make-array (array-total-size grid) :fill-pointer 0)))
    (dotimes (j height)
      (dotimes (i width)
	(let ((occupier (cell-owner (aref grid j i))))
	  (when (or (null occupier)
		    (= occupier (1- (robot-me state))))
	    (vector-push (cons i j) moves)))))
    (let ((move (aref moves (random (length moves)))))
      (play-cell game player (car move) (cdr move)))))

(defmethod player-turn-begin (game (player robot-player))
  (unless (slot-boundp player 'robot-state)
    (setf (slot-value player 'robot-state) (make-robot-state game player)))
  (robot-move game player))

(unless (find 'robot-player *player-types*)
  (setf *player-types*
	(append *player-types* '(robot-player))))

#+debug
(start-atom-game :width 7
		 :players '("Alice"
			    ("RoboBob" :type robot-player)))