;;; -*- mode: lisp; syntax: common-lisp -*-

(defparameter *board*
  (make-array '(9 9)
              :initial-contents '((1 0 0 0 0 7 4 0 0)
                                  (9 0 6 4 0 0 0 0 0)
                                  (0 5 0 8 3 0 0 0 0)
                                  (3 6 0 0 0 0 0 0 5)
                                  (0 0 0 0 2 0 0 0 0)
                                  (5 0 8 0 0 0 0 1 4)
                                  (0 0 0 0 7 3 0 9 0)
                                  (0 0 0 0 0 8 7 0 6)
                                  (0 0 5 9 0 0 0 0 1))))

(defun get-row (array index)
  (let ((result (make-array 9)))
    (dotimes (i 9)
      (setf (elt result i) (aref array index i)))
    result))

(defun get-column (array index)
  (let ((result (make-array 9)))
    (dotimes (i 9)
      (setf (elt result i) (aref array i index)))
    result))

(defun get-square (array n m)
  (let ((result (make-array 9)))
    (dotimes (i 3)
      (dotimes (j 3)
        (setf (elt result (+ (* i 3) j)) (aref array (+ n i) (+ m j)))))
    result))

(defun board-coherent-p (board i j)
  (let ((result t))
    (dotimes (k 9)
      (when (or (> (count (1+ k) (get-row board i)) 1)
                (> (count (1+ k) (get-column board j)) 1)
                (> (count (1+ k) (get-square board
                                             (* (floor (/ i 3)) 3)
                                             (* (floor (/ j 3)) 3))) 1))
        (setf result nil)))
    result))

(defun solve-sudoku (board)
  (let ((filled t) m n)
    (dotimes (i 9)
      (dotimes (j 9)
        (when (= (aref board i j) 0)
          (setf filled nil m i n j))))
    (if filled
        (describe board)
        (dotimes (k 9)
          (setf (aref board m n) (1+ k))
          (when (board-coherent-p board m n)
            (solve-sudoku board))
          (setf (aref board m n) 0)))))