;;;;  Sudoku -  Fill a 9x9 grid so that every row, every column and every 3x3
;;;;            grid contains the numbers 1 to 9.
;;; 
;;;   Define the problem by setting *grid* to the starting position
;;;   (see the (set-problem[1-8]) defuns for examples) or using 
;;;   (setg i j k) to set individual grid elements.
;;; 
;;;   A number of canned problems are provided, (set-problem[1-8])
;;; 
;;;   Type (solve) to determine the solution.
;;; 
;;;   Notes:
;;;     Functions should work for other than 9x9 grids, but that's not
;;;     been tested.
;;; 
;;;   Modification History
;;;     2005/05/31    Written                          mpw
;;;     2005/07/12    Solving speed improved           mpw

;; eval-when required for clisp (sbcl and cmucl don't seem to need it)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defconstant grid-size 9
    "Number of rows and columns in grid.")
  (defconstant subgrid-size 3
    "Number of rows and columns in subgrid."))

(defparameter *grid* 
  (make-array (list grid-size grid-size) :initial-element 0)
  "Define initial grid, all elements zero (i.e. unfilled).")

;; generate list of valid grid rows and columns at compile time
(defmacro grid-ranks()
  `',(let ((acc nil))
          (dotimes (i grid-size)
            (push i acc))
          acc))

;; generate list of subgrid origin coordinates at compile time
(defmacro subgrid-origins()
  `',(let ((acc nil))
          (do ((i 0 (+ i subgrid-size)))
              ((>= i grid-size) acc)
            (do ((j 0 (+ j subgrid-size)))
                ((>= j grid-size))
              (push (list i j) acc)))))

;;;  Utility functions
(defun rotate-list (ls n)
  "Rotate list ls by n elements."
  (append (subseq ls n) (subseq ls 0 n)))

(defun copy-array (array) 
  "Copy and return array."
  (let ((new (make-array (array-dimensions array) :displaced-to array))) 
    (adjust-array new (array-dimensions array) :displaced-to nil)))

(defun map-int (fn n)
  "Map function fn over integers 0 to n-1, returning results as list.
(courtesy Paul Graham)"
  (let ((acc nil))
    (dotimes (i n)
      (push (funcall fn i) acc))
    (nreverse acc)))

(defun combine (ls1 ls2 &optional acc)
  "Return list by combining each element in ls1 with each element in ls2."
  (cond ((null ls1)
         acc)
        (t
         (combine (cdr ls1) ls2
                  (append (mapcar #'(lambda (e) (list (car ls1) e)) ls2)
                          acc)))))

(defun has-duplicates (ls &optional acc)
  "Return t if ls contains duplicates, nil otherwise."
  (cond ((null ls) nil)
        ((member (car ls) acc) t)
        (t (has-duplicates (cdr ls) (cons (car ls) acc)))))

;;;  
(defun clear ()
  "Set all elements of *grid* to zero."
  (dotimes (i (* grid-size grid-size))
    (setf (row-major-aref *grid* i) 0)))

(defun valid-elements ()
  "Return t if all elements in grid are between 0 and grid-size, inclusive."
  (dotimes (i (* grid-size grid-size))
    (let ((ev (row-major-aref *grid* i)))
      (when (or (< ev 0) (> ev grid-size))
        (return-from valid-elements nil))))
  t)

(defun setg (i j v)
  "Set grid element i j to v."
  (if (and (array-in-bounds-p *grid* i j)
           (>= v 0) 
           (<= v grid-size))
      (setf (aref *grid* i j) v)
      nil))

(defun invalid-grid ()
  "Return t for invalid grid, nil otherwise.
Partially filled grids that conform to the rules are considered valid."
  (or (some #'invalid-col (grid-ranks))
      (some #'invalid-row (grid-ranks))
      (some #'invalid-subgrid (subgrid-origins))
      (not (valid-elements))))

(defun invalid-row (i)
  "Return t if row i is invalid."
  (has-duplicates (in-use-row i)))

(defun invalid-col (j)
  "Return t if col j is invalid."
  (has-duplicates (in-use-col j)))

(defun invalid-subgrid (ij)
  "Return t if subgrid with element ij is invalid."
  (has-duplicates (in-use-subgrid (car ij) (cadr ij))))

(defun valid-grid ()
  "Return *grid* for complete and valid grid, nil otherwise."
  (and (every #'valid-col (grid-ranks))
       (every #'valid-row (grid-ranks))
       (every #'valid-subgrid (subgrid-origins))
       *grid*))
 
(defun valid-row (i)
  "Return t if row i is complete and valid."
    (= (length (remove-duplicates (in-use-col i))) grid-size))

(defun in-use-row (i)
  "Return list of integers already specified in row i."
  (let ((x))
    (dotimes (n grid-size)
      (let ((k (aref *grid* i n)))
        (unless (= k 0) (push k x))))
    x))  


(defun valid-col (j)
  "Return t if column j is complete and valid."
    (= (length (remove-duplicates (in-use-col j))) grid-size))

(defun in-use-col (j)
  "Return list of integers already specified in column j."
  (let ((x))
    (dotimes (n grid-size)
      (let ((k (aref *grid* n j)))
        (unless (= k 0) (push k x))))
    x))

(defun valid-subgrid (ij)
  "Returns t if the subgrid in which ij resides is complete and valid."
  (= (length (remove-duplicates (in-use-subgrid (car ij) (cadr ij))))
     grid-size))

(defun in-use-subgrid (i j)
  "Return list of integers already used in the subgrid in which ij resides."
  (let ((x nil) 
        (gi (* (floor (/ i subgrid-size)) subgrid-size))
        (gj (* (floor (/ j subgrid-size)) subgrid-size)))
      (dotimes (k subgrid-size)
        (dotimes (l subgrid-size)
          (let ((v (aref *grid* (+ gi k) (+ gj l))))
            (unless (= v 0) (push v x)))))
      x))

(defun in-use (i j)
  "Return list of integers invalid for element i j."
    (remove-duplicates 
     (append (in-use-subgrid i j) (in-use-row i) (in-use-col j))))

(defun valid-at (i j)
  "Return list of integers valid at element i j."
  (set-difference (mapcar #'1+ (grid-ranks)) (in-use i j)))
  
(defun all-valid ()
  "Return array with each element a list of valid ints for that grid location."
  (let ((b (make-array (list grid-size grid-size) :initial-element nil)))
    (dotimes (i grid-size)
      (dotimes (j grid-size)
        (when (= (aref *grid* i j) 0) (setf (aref b i j) (valid-at i j)))))
    b))

(defun affected-ij (i j)
  "Return list of grid locations affected by a change to i j."
  (let ((gi (* (floor (/ i subgrid-size)) subgrid-size))
        (gj (* (floor (/ j subgrid-size)) subgrid-size)))
    (remove-duplicates 
     (append (map-int #'(lambda (n) (list i n)) grid-size)
             (map-int #'(lambda (n) (list n j)) grid-size)
             (combine (map-int #'(lambda (n) (+ gi n)) subgrid-size)
                      (map-int #'(lambda (n) (+ gj n)) subgrid-size)))
     :test #'tree-equal)))

(defun valid-ij (i j)
  "A different (and unused) implementation of affected-ij.
(very marginally faster)"
  (let ((acc nil)
        (gi (* (floor (/ i subgrid-size)) subgrid-size))
        (gj (* (floor (/ j subgrid-size)) subgrid-size)))
    (dotimes (n grid-size)
      (push (list i n) acc))
    (dotimes (n grid-size)
      (push (list n j) acc))
    (dotimes (k subgrid-size)
      (dotimes (l subgrid-size)
        (push (list (+ gi k) (+ gj l)) acc)))
    (remove-duplicates acc :test #'tree-equal)))

;; set-affected improves the solving speed by adjusting the lists of
;; possible values when a new value is entered into *grid*.  We don't
;; recompute all grid location lists (most of which are unchanged).
(defun set-affected (b i j)
  "Removes the value set at i j of *grid* from the lists in b."
  (let ((newb (copy-array b)))
    (mapc #'(lambda (ij)
              (setf (aref newb (car ij) (cadr ij)) 
                    (remove (aref *grid* i j) (aref b (car ij) (cadr ij))))) 
          (affected-ij i j))
    (setf (aref newb i j) nil)      ; since i j is set, nothing to try
    newb))

(defun sorted-array-index (b)
  "Returns list of indexes in array b, sorted in shortest list order.
Process array which holds list of valid contents for each location in
the grid.  Returns list, with each element a list of the number of
valid ints at a grid location and the row and column of the location.
List is sorted in order of number of valid elements at each grid
location."
  (let ((x nil))
    (dotimes (i grid-size)
      (dotimes (j grid-size)
        ;; only return values where grid setting is unknown
        (when (aref b i j)              
          (push (list (length (aref b i j)) i j)  x))))
    (sort x #'< :key #'car)))

(defun solve-grid (b)
  "Solve grid; *grid* returned if solved, else returns nil.
An array containing lists of possible values for the *grid* locations is
passed as b."
  (let* ((try-list (sorted-array-index b))
         (i (cadar try-list))
         (j (caddar try-list)))
    (cond  ((null try-list)
            (valid-grid))
           (t 
            (dolist (k (aref b i j))
              (setf (aref *grid* i j) k)
              (when (solve-grid (set-affected b i j))
                (return-from solve-grid *grid*)))
            (setf (aref *grid* i j) 0)
            nil))))

(defun solve ()
  "Check for valid starting grid, then attempt to solve."
  (when (not (invalid-grid)) 
    (solve-grid (all-valid))))

(defun solve-grid1 ()
  "Solve grid; *grid* returned if solved, else returns nil (slow version)."
  (let* ((b (all-valid))
         (try-list (sorted-array-index b))
         (i (cadar try-list))
         (j (caddar try-list)))
    (cond  ((null try-list)
            (valid-grid))
           (t 
            (dolist (k (aref b i j))
              (setf (aref *grid* i j) k)
              (when (solve-grid1) (return-from solve-grid1 *grid*)))
            (setf (aref *grid* i j) 0)
            nil))))

(defun solve1 ()
  "Check for valid starting grid, then attempt to solve (slow version)."
  (when (not (invalid-grid)) 
    (solve-grid1)))

(defun set-valid-grid ()
  "Define simple, valid grid for testing."
  (let ((row (mapcar #'1+ (grid-ranks))))
    (dotimes (i grid-size)
      (dotimes (j grid-size)
        (setf (aref *grid* i j) (nth j row)))
      (setf row (rotate-list row (if (= (mod (+ 1 i) subgrid-size) 0) 
                                    (1+ subgrid-size) subgrid-size))))))

(defun set-problem1 ()
  "Define a difficult (ha!) 9x9 grid  problem."
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents 
                           '((0 0 3 0 0 0 0 0 0)
                             (0 0 2 4 0 1 0 9 0)
                             (9 1 0 0 0 2 0 0 0)
                             (0 8 0 0 0 3 4 5 0)
                             (0 0 0 0 4 0 0 0 0)
                             (0 7 6 5 0 0 0 1 0)
                             (0 0 0 6 0 0 0 2 3)
                             (0 2 0 7 0 9 8 0 0)
                             (0 0 0 0 0 0 7 0 0)))))

(defun set-problem2 ()
  "Another 9x9 grid problem."
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents 
                           '((0 0 6 0 0 2 0 0 0)
                             (0 0 0 0 5 0 4 0 2)
                             (0 7 0 4 9 0 0 1 0)
                             (7 0 4 0 0 9 2 0 0)
                             (1 0 0 0 0 0 0 0 8)
                             (0 0 9 1 0 0 5 0 3)
                             (0 1 0 0 4 6 0 5 0)
                             (6 0 5 0 7 0 0 0 0)
                             (0 0 0 5 0 0 3 0 0)))))

(defun set-problem3 ()
  "A medium difficulty 9x9 grid problem."
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents 
                           '((0 0 0 0 2 0 0 0 1)
                             (0 8 0 0 7 0 0 6 0)
                             (0 2 0 1 0 0 0 5 0)
                             (9 0 0 4 0 0 3 0 0)
                             (0 0 4 0 0 0 5 0 0)
                             (0 0 6 0 0 2 0 0 7)
                             (0 9 0 0 0 3 0 8 0)
                             (0 1 0 0 5 0 0 2 0)
                             (7 0 0 0 6 0 0 0 0)))))


(defun set-problem4 ()
  "An easy 9x9 grid problem."
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents 
                           '((0 8 0 4 0 5 0 0 0)
                             (4 0 1 0 0 0 6 0 0)
                             (0 6 0 0 1 0 0 4 0)
                             (7 0 0 2 0 4 0 0 8)
                             (0 0 3 0 5 0 7 0 0)
                             (9 0 0 6 0 8 0 0 4)
                             (0 7 0 0 9 0 0 3 0)
                             (0 0 8 0 0 0 2 0 5)
                             (0 0 0 3 0 1 0 6 0)))))

(defun set-problem5 ()
  "A 'fiendish' 9x9 grid problem."
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents 
                           '((0 6 0 4 0 8 0 1 0)
                             (0 0 9 0 0 0 5 0 0)
                             (0 0 0 5 0 7 0 3 0)
                             (0 3 0 0 0 0 0 0 5)
                             (0 0 0 2 6 4 0 0 0)
                             (8 0 0 0 0 0 0 2 0)
                             (0 1 0 7 0 9 0 0 0)
                             (0 0 4 0 0 0 9 0 0)
                             (0 8 0 1 0 3 0 5 0)))))

(defun set-problem6 ()
  "Easy 9x9 problem"
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents
                           '((0 6 0 0 8 0 0 7 4)
                             (7 3 0 0 0 9 0 1 2)
                             (0 0 1 0 0 0 6 0 0)
                             (0 0 0 3 0 5 0 2 0)
                             (4 0 0 0 9 0 0 0 3)
                             (0 8 0 6 0 2 0 0 0)
                             (0 0 4 0 0 0 1 0 0)
                             (3 5 0 7 0 0 0 6 8)
                             (6 1 0 0 5 0 0 9 0)))))

(defun set-problem7 ()
  "Medium 9x9 problem"
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents
                           '((0 0 0 0 0 6 1 0 0)
                             (0 0 0 0 0 3 0 8 0)
                             (0 0 9 4 0 0 5 0 2)
                             (0 2 0 5 0 0 0 4 0)
                             (5 0 7 0 0 0 9 0 3)
                             (0 8 0 0 0 1 0 6 0)
                             (7 0 6 0 0 8 2 0 0)
                             (0 4 0 7 0 0 0 0 0)
                             (0 0 1 9 0 0 0 0 0)))))

(defun set-problem8 ()
  "Medium 9x9 problem"
  (setf *grid* (make-array (list grid-size grid-size)
                           :initial-contents
                           '((6 0 0 0 1 0 0 0 7)
                             (4 0 7 0 0 0 2 0 5)
                             (0 0 2 0 3 0 9 0 0)
                             (7 0 0 0 4 0 0 0 2)
                             (0 0 5 7 0 9 1 0 0)
                             (8 0 0 0 6 0 0 0 3)
                             (0 0 3 0 7 0 5 0 0)
                             (9 0 6 0 0 0 8 0 4)
                             (2 0 0 0 9 0 0 0 6)))))