(in-package :sudoku-algorithm)

(defparameter *board-width* 9)

;;; This class represents units that contain a list of cells.
;;; A unit can include cells in a row of Sudoku board,
;;; cells in a column of board, or cells in a square of board.
(defclass unit ()
  ((%cells :initarg :cells :accessor cells)))

(defun make-unit ()
  (make-instance 'unit :cells (make-list 0)))

;;; Given a unit, make sure this unit is the 
;;; parent of all its cells. 
(defun add-parent-to-cells-of-unit (unit)
  (loop for cell in (cells unit)
	do (push unit (parents cell))))

;;; This class represents cells that contain possible values.
;;; These cells also contain a list of units to which they belong.
(defclass cell ()
  ((%parents :initarg :parents :accessor parents)
   (%possibilities :initarg :possibilities :accessor possibilities)))

(defun make-cell (board-width)
  (make-instance 'cell
		 :parents '()
		 :possibilities (make-array board-width
                                            :element-type 'bit
                                            :initial-element 1)))

(defun erase-possibilities (cell)
  (loop for i from 0 below (length (possibilities cell))
	do (setf (aref (possibilities cell) i) 0)))

(defun set-possibilities (cell index value)
  (setf (aref (possibilities cell) index) value))

;;; return a true value if and only if there is more than one
;;; possible value for the cell. 
(defun check-hole (cell)
  (/= (symbolset-cardinality (possibilities cell)) 1))

(defun find-possibilities (cell)
  (let* ((leng (length (possibilities cell)))
	 (tmp (make-array leng :element-type 'bit :initial-element 1)))
    (loop for unit across (parents cell)
	  do (loop for cell1 across (cells unit)
		   do (unless (check-hole cell1)
			(let ((order-1 (position 1 (possibilities cell1))))
			  (setf (aref tmp order-1) 0)))))
    (setf (possibilities cell) tmp)))

;;; This class represents a Sudoku board.
;;; It includes an array of symbols that is used to display characters,
;;; an array of cells in the board,
;;; and a list of all units (row-units, column-units, square-units).
(defclass game ()
  ((%symbols :initarg :symbols :accessor symbols)
   (%cells :initarg :cells :accessor cells)
   (%units :initarg :units :accessor units)))

(defun make-game (board-width)
  (make-instance 'game
		 :symbols (make-array board-width)
		 :cells (make-array (list board-width board-width))
		 :units '()))

(defun create-mapping-vector (board-width)
  (let ((v (make-array board-width)))
    (loop for i from 0 below board-width
	  do (setf (aref v i) (1+ i)))
    ;;(shuffle-vector v) This statement is commented for easy checking
    (return-from create-mapping-vector v)))

(defun map-over-rectangle (fun game start-row height start-col width)
  (loop for row from start-row
	repeat height
	do (loop for col from start-col
		 repeat width
		 do (funcall fun (aref (cells game) row col)))))

(defun copy-rectangle-to-unit (game start-row height start-col width unit)
  (map-over-rectangle (lambda (cell) (push cell unit))
		      game start-row height start-col width))

(defun symbolset-cardinality (symbolset)
  (count 1 symbolset))

(defun symbolset-union (symbolset1 symbolset2)
  (bit-ior symbolset1 symbolset2))

(defun symbolset-difference (symbolset1 symbolset2)
  (bit-andc2 symbolset1 symbolset2))

(defun create-unit-for-testing (choice)
  (let ((board-width *board-width*)
	(unit (make-unit))
	(unit1 (make-unit))
	(unit2 (make-unit))
	(unit3 (make-unit)))
    ;; initialize cells for unit1
    ;; strategy1 can be applied for unit1
    (loop for i from 0 below board-width
	  do (let ((cell (make-cell board-width)))
	       (erase-possibilities cell)
	       (set-possibilities cell i 1)
	       (push cell (cells unit1))))
    (setf (possibilities (second (cells unit1))) #*000000110)
    ;; initialize cells for unit2
    ;; strategy2 can be applied for unit2
    (loop for i from 0 below board-width
	  do (let ((cell (make-cell board-width)))
	       (setf (possibilities cell) #*111111000)
	       (push cell (cells unit2))))
    (setf (possibilities (second (cells unit2))) #*000001100)
    (setf (possibilities (fourth (cells unit2))) #*000001010)
    ;; initialize cells for unit3
    ;; strategy3 can be applied for unit3
    (loop for i from 0 below board-width
	  do (let ((cell (make-cell board-width)))
	       (setf (possibilities cell) #*111111000)
	       (push cell (cells unit3))))
    (setf (possibilities (second (cells unit3))) #*001000000)
    (setf (possibilities (fourth (cells unit3))) #*000010000)
    (cond ((= choice 1) (setf (cells unit) (cells unit1)))
	  ((= choice 2) (setf (cells unit) (cells unit2)))
	  ((= choice 3) (setf (cells unit) (cells unit3))))
    (return-from create-unit-for-testing unit)))

(defun strategy1 (unit)
  (let ((ambiguous-cells (remove-if-not #'check-hole (cells unit))))
    (if (= (length ambiguous-cells) 1)
	;; then the strategy is applicable
	(let ((cell (first ambiguous-cells)))
	  (setf (possibilities cell)
		(symbolset-difference
		 (possibilities cell)
		 (reduce #'symbolset-union
			 (remove cell (cells unit))
			 :key #'possibilities)))
	  (return-from strategy1 (list cell)))
	;; else return an empty list
	(return-from strategy1 '()))))

(defun strategy2 (unit)
  (let ((ambiguous-cells (remove-if-not #'check-hole (cells unit))))
    (loop for cell in ambiguous-cells
	  do (let ((diff
		    (symbolset-difference
		     (possibilities cell)
		     (reduce #'symbolset-union
			     (remove cell (cells unit))
			     :key #'possibilities))))
	       (when (= (symbolset-cardinality diff) 1)
		 (setf (possibilities cell) diff)
		 (return-from strategy2 (list cell))))
	  finally (return-from strategy2 '()))))

(defun strategy3 (unit)
  (let ((ambiguous-cells (remove-if-not #'check-hole (cells unit)))
	(unchanged-cells (remove-if #'check-hole (cells unit))))
    (loop for cell in unchanged-cells
	  do (let ((order-1 (position 1 (possibilities cell))))
	       (loop for hole in ambiguous-cells
		     do (when (= (aref (possibilities hole) order-1) 1)
			  (set-possibilities hole order-1 0)
			  (return-from strategy3 (list hole)))))
	  finally (return-from strategy3 '()))))

(defun create-initial-board (board-width)
  (let* ((board (make-array (list board-width board-width)))
	 (sqrt-board-width (isqrt board-width)))
    (loop for offset1 from 0 below sqrt-board-width
	  for block-start from 0 below board-width by sqrt-board-width
	  do (loop for row from block-start
		   for offset2 from 0 by sqrt-board-width
		   repeat sqrt-board-width
		   do (loop for col from 0 below board-width
			    do (setf (aref board row col)
				     (mod (+ col offset1 offset2)
                                          board-width)))))
    (return-from create-initial-board board)))

;;; Exchange two non-overlapping rectangles having the same shape
(defun exchange-rectangles (board
                            start-row-1 start-col-1
                            height width
                            start-row-2 start-col-2)
  (unless (and (= start-row-1 start-row-2) (= start-col-1 start-col-2))
    (loop for row-1 from start-row-1
	  for row-2 from start-row-2
	  repeat height
	  do (loop for col-1 from start-col-1
		   for col-2 from start-col-2
		   repeat width
		   do (rotatef (aref board row-1 col-1)
			       (aref board row-2 col-2))))))

(defun exchange-rows (board row-1 row-2)
  (let ((board-width (array-dimension board 0)))
    (exchange-rectangles board row-1 0 1 board-width row-2 0)))

(defun exchange-columns (board col-1 col-2)
  (let ((board-height (array-dimension board 1)))
    (exchange-rectangles board 0 col-1 board-height 1 0 col-2)))

(defun exchange-blocks-of-rows (board row-1 row-2)
  (let* ((board-width (array-dimension board 0))
	 (sqrt-board-width (isqrt board-width)))
    (exchange-rectangles board row-1 0 sqrt-board-width board-width row-2 0)))

(defun exchange-blocks-of-columns (board col-1 col-2)
  (let* ((board-width (array-dimension board 0))
	 (sqrt-board-width (isqrt board-width)))
    (exchange-rectangles board 0 col-1 board-width sqrt-board-width 0 col-2)))

;;; This function computes a random permutation of n elements.  It
;;; works as follows: At each iteration, there is a prefix of i random
;;; elements (initially 0) , and another element of the prefix is
;;; computed by exchanging element i and a random element among the
;;; elements from i to n-1 inclusive.  There are n-i [(n-1) - i + 1]
;;; such elements, so the RANDOM function has to be called with n-i,
;;; which gives us a value between 0 and n-i-1 inclusive.  By adding i
;;; to that value, we get a value between i and n-1 inclusive.
;;; Instead of stipulating how the elements are stored, we take as an
;;; argument an exchange function that is called with i and the
;;; element number of the element to exchange with element i.  This function
;;; is responsible for accessing the exact physical representation of the n 
;;; elements. 
(defun compute-random-permutation (n exchange-fun)
  (loop for i from 0 to (- n 2)
	do (let ((e (+ i (random (- n i)))))
	     (unless (= i e)
	       (funcall exchange-fun i e)))))

;;; To shuffle a vector, compute a random permutation 
;;; of its elements. 
(defun shuffle-vector (vector)
  (compute-random-permutation
   (length vector)
   (lambda (i j)
     (rotatef (aref vector i) (aref vector j)))))

(defun shuffle-rows-within-block (board block-start)
  (let ((N (isqrt (array-dimension board 0))))
    (compute-random-permutation
     N (lambda (r1 r2)
         (exchange-rows board (+ block-start r1) (+ block-start r2))))))

(defun shuffle-columns-within-block (board block-start)
  (let ((N (isqrt (array-dimension board 0))))
    (compute-random-permutation
     N (lambda (c1 c2)
         (exchange-columns board (+ block-start c1) (+ block-start c2))))))

(defun shuffle-blocks-of-rows (board)
  (let ((N (isqrt (array-dimension board 0))))
    (compute-random-permutation
     N (lambda (r1 r2)
         (exchange-blocks-of-rows board (* r1 N) (* r2 N))))))

(defun shuffle-blocks-of-columns (board)
  (let ((N (isqrt (array-dimension board 0))))
    (compute-random-permutation
     N (lambda (c1 c2)
         (exchange-blocks-of-columns board (* c1 N) (* c2 N))))))

(defun shuffle-board (board)
  (let* ((board-width (array-dimension board 0))
	 (sqrt-board-width (isqrt board-width)))
    (loop for block-start from 0 below board-width by sqrt-board-width
       do (shuffle-rows-within-block board block-start))
    (loop for block-start from 0 below board-width by sqrt-board-width
       do (shuffle-columns-within-block board block-start))
    (shuffle-blocks-of-rows board)
    (shuffle-blocks-of-columns board)))

(defun set-sample-game (game)
  (let* ((board-width (array-dimension (cells game) 0))
	 (easy-board (make-array (list board-width board-width)
				 :initial-contents '((0 6 5 0 2 0 0 7 0)
						     (7 2 9 5 3 0 0 0 0)
						     (0 4 0 8 0 0 2 0 9)
						     (0 5 1 0 8 0 7 0 2)
						     (0 0 0 7 0 2 0 0 0)
						     (2 0 7 0 4 0 3 9 0)
						     (6 0 4 0 0 1 0 2 0)
						     (0 0 0 0 9 8 6 3 7)
						     (0 9 0 0 6 0 1 4 0))))
	 (hard-board (make-array (list board-width board-width)
				 :initial-contents '((0 0 0 3 0 8 0 5 4)
						     (8 5 0 6 9 0 0 0 0)
						     (2 0 0 0 4 0 0 8 0)
						     (6 0 0 0 0 0 7 0 1)
						     (7 2 0 0 0 0 0 4 5)
						     (3 0 5 0 0 0 0 0 2)
						     (0 7 0 0 5 0 0 0 3)
						     (0 0 0 0 8 6 0 2 9)
						     (4 6 0 9 0 3 0 0 0))))
	 (used-board (make-array (list board-width board-width))))
    (setf used-board easy-board)
    (loop for row from 0 below board-width
	  do (loop for col from 0 below board-width
		   for value = (aref used-board row col)
		   do (when (> value 0)
			(erase-possibilities (aref (cells game) row col))
			(set-possibilities (aref (cells game) row col)
                                           (- value 1) 1))))))

(defun create-game (board)
  (let* ((board-width (array-dimension board 0))
	 (sqrt-board-width (isqrt board-width))
	 (game (make-game board-width)))
    ;; Create mapping vector
    (setf (symbols game) (create-mapping-vector board-width))
    ;; Create an array of cell instances
    (loop for row from 0 below board-width
	  do (loop for col from 0 below board-width
		   do (setf (aref (cells game) row col)
                            (make-cell board-width))))
    ;; Initiate values for all cells of game
    ;; We will replace this call by the function which finds a game
    (set-sample-game game)
    ;; Create unit instances corresponding to rows
    (loop for row from 0 below board-width
	  do (let ((unit (make-unit)))
	       (copy-rectangle-to-unit game row 1 0 board-width unit)
	       (push unit (units game))
	       (add-parent-to-cells-of-unit unit)))
    ;; Create unit instances corresponding to columns
    (loop for col from 0 below board-width
	  do (let ((unit (make-unit)))
	       (copy-rectangle-to-unit game 0 board-width col 1 unit)
	       (push unit (units game))
	       (add-parent-to-cells-of-unit unit)))
    ;; Create unit instances corresponding to small squares
    (loop for row from 0 below board-width by sqrt-board-width
	  do (loop for col from 0 below board-width by sqrt-board-width
		   do (let ((unit (make-unit)))
			(copy-rectangle-to-unit
                         game row sqrt-board-width col sqrt-board-width unit)
			(push unit (units game))
			(add-parent-to-cells-of-unit unit))))
    (return-from create-game game)))

(defun copy-game (game)
  (let* ((board-width (array-dimension (cells game) 0))
	 (copied-game (make-game board-width)))
    (setf (symbols copied-game) (symbols game))
    (setf (cells copied-game) (cells game))
    (setf (units copied-game) (units game))
    (return-from copy-game copied-game)))

(defun print-board (game)
  (let ((board-width (array-dimension (cells game) 0)))
    (loop for row from 0 below board-width
	  do (format t "~%")
	     (loop for col from 0 below board-width
		   for cell = (aref (cells game) row col)
		   do (if (check-hole cell)
			  (format t "- ")
			  (let ((order-1 (position 1 (possibilities cell))))
			    (format t "~S " (aref (symbols game) order-1))))))))
  
(defun main ()
  (let* ((board (create-initial-board *board-width*))
	 (game (create-game board))
	 (copied-game (copy-game game)))
    (print-board game)
    (print-board copied-game)))

(defun test-strategy (choice)
  (let ((unit (create-unit-for-testing choice))
	(changed-cells nil))
    (loop for cell in (cells unit)
	  do (describe cell))
    (cond ((= choice 1) (setf changed-cells (strategy1 unit)))
	  ((= choice 2) (setf changed-cells (strategy2 unit)))
	  ((= choice 3) (setf changed-cells (strategy3 unit))))
    (format t "~%The changed cell is:")
    (describe (first changed-cells))))