(defvar *unsolved* '-)

(defun unsolved (x)
  (eql x *unsolved*))

(defun solved (x)
  (numberp x))

(defun print-sudoku (sudoku)
  (loop for y from 0 below 9
        finally (terpri)
        do 
	(when (zerop (mod y 3)) (format t "~%"))
	(loop for x from 0 below 9 finally (terpri) do
		 (when (zerop (mod x 3)) (format t " "))
		 (format t "~A" (if (solved (aref sudoku y x))
				    (aref sudoku y x)
				   *unsolved*)))))

(let ((mask (make-array 10
			:initial-element nil
			:adjustable nil)))

  (defun digits-in-region (sudoku x y)
    (declare (optimize (speed 3) (safety 0) (debug 0))
	     (type simple-array sudoku)
	     (type (integer 0 8) x y))
    (loop
     with x0 = (* 3 (truncate x 3))
     with y0 = (* 3 (truncate y 3))
     with x1 = (+ x0 2)
     with y1 = (+ y0 2)
     for x from x0 to x1
     do (loop for y from y0 to y1
	      for digit = (aref sudoku y x)
	      when (solved digit)
	      do (setf (aref mask digit) nil))))
  
  (defun digits-in-row (sudoku y)
    (declare (optimize (speed 3) (safety 0) (debug 0))
	     (type (simple-array sudoku))
	     (type (integer 0 8) y))
    (loop for x from 0 below 9
	  for digit = (aref sudoku y x)
	  when (solved digit)
	  do (setf (aref mask digit) nil)))
  
  (defun digits-in-column (sudoku x)
    (declare (optimize (speed 3) (safety 0) (debug 0))
	     (type (simple-array sudoku))
	     (type (integer 0 8) x))
    
    (loop for y from 0 below 9
	  for digit = (aref sudoku y x)
	  when (solved digit)
	  do (setf (aref mask digit) nil)))
  
  (defun possible-digits (sudoku x y)
    (declare (optimize (speed 3) (safety 0) (debug 0))
	     (type (simple-array sudoku))
	     (type (integer 0 8) x y))
    (loop for i from 1 below 10
	  do (setf (aref mask i) t))
    (digits-in-region sudoku x y)
    (digits-in-row    sudoku y)
    (digits-in-column sudoku x)
  ;; (format t "~A~%" *mask*)
  (loop for index in '(1 2 3 4 5 6 7 8 9)
	when (aref mask index)
	collect index)))
  
  
(defun print-cells (sudoku pairs)
  (when pairs
    (format t "~A,~A: ~A~%" (car (car pairs))
	    (cdr (car pairs))
	    (possible-digits sudoku  (car (car pairs))
			     (cdr (car pairs))))
    (print-cells sudoku (cdr pairs))))

(defun solve (sudoku)
  (declare (optimize (speed 3) (safety 0) (debug 0))
	   (type simple-array sudoku)
	   (type (simple-array unsigned-byte (9 9)) sudoku))

  (labels ((sort-cells (pairs)
		       ;; caculate a list similar to the given list of pairs
		       ;; except that an element which minimizes
		       ;; #'possible-digits is moved to the beginning of
		       ;; the list.
		       (min-and-rest pairs
				     :key
				     (lambda (pair)
				       (length (the list (possible-digits
							  sudoku
							  (car pair)
							  (cdr pair)))))))
	   (solve-next (pairs)
		       (unless pairs
			 (print-sudoku sudoku)
			 (return-from solve))
		       (let ((pair (car pairs))
			     (pairs (cdr pairs)))
			 (let ((x (car pair))
			       (y (cdr pair)))
			   (let ((possible-digits
				  (possible-digits sudoku x y)))
			     ;; if there are no possible digits,
			     ;; then backtrack
			     (when possible-digits
			       ;; try each possible solution for this
			       ;; position until one works or we have to
			       ;; backtrack.
			       (dolist (digit possible-digits)
				 (setf (aref sudoku y x) digit)
				 ;; move the remaining unsolved cell which has
				 ;; the minimum number of possible digits to
				 ;; the beginning of the list of remaining
				 ;; cells, and solve away.
				 (solve-next (sort-cells pairs)))
			       ;; return the cell to unsolved,
			       ;; and backtrack.
			       (setf (aref sudoku y x) *unsolved*)))))))
    ;; call solve-next with list of all unsolved cells
    ;; sorted into in order of increasing possible digits.
    ;; Note, this sorting only occures once at the top level,
    ;; thereafter it is hoped that the list is almost sorted.
    ;; By almost sorted, i mean that every element is not too far
    ;; from the ideal sorted position.
    (solve-next (sort (loop for x from 0 below 9
			    nconc (loop for y from 0 below 9
					when (unsolved (aref sudoku y x))
					collect (cons x y)))
		      #'<
		      :key (lambda (pair)
			     (length (possible-digits sudoku
						      (car pair)
						      (cdr pair))))))))

;; if the first element of the given list minimizes the key function,
;;   then return the list,
;; else build a new list with the minimizing element first
;;   followed by the rest of the list.  If the minimizing element
;;   appears more the once, the first occuranc will simply be moved
;;   to the beginning of the new list.
;; E.g.,
;;   ( 3 4 5 6 0 6 7 0 2 3)
;;   ---> ( 0 3 4 5 6 6 7 0 2 3)
(defun min-and-rest (list &key (key #'identity) (test #'<))
  (loop with min = (car list)
	for elem in list
	;; when test < min
	when (funcall test (funcall key elem) (funcall key min))
	do (setq min elem) 
	finally (return (if (eql min (car list))
			    list
			  (cons min (remove-preserving-tail min list))))))

;; like lconc except that it does not
;; advance the cdr of the conc to the end of the list
;; until necessary.  for lconc and tconc the conc structure
;; usually is in a state where (cdr conc) is the last cons
;; cell of the list.   in the case of lazy-lconc and lazy-tconc
;; (cdr conc) is just some cons cell but will be advanced to the
;; end on demand whenevery anything needs to be added.
(defun lazy-lconc (conc list)
  (let ((ptr (cdr conc)))
    (if ptr
	(progn
	  (loop while (cdr ptr)
		do (pop ptr))
	  (setf (cdr ptr) list)
	  (setf (cdr conc) ptr))
      (progn
	(setf (car conc) list)
	(setf (cdr conc) list)))))

(defun lazy-tconc (conc item)
  (lazy-lconc conc (list item)))

;; Remove the given element the first time it occurs
;; in the list consing as few cells as possible,
;; and only traversing as far as necessary into the list.
;; This function is completely non-destructive.
;; This is done by using tconc to collect the elements
;; of the list until we reach the unwanted item,
;; then using lconc to setf cdr to the remaining elements
;; without traversing any further.
;; An annoying side effect is that if the unwanted element
;; is not found then the entire list is re-allocated and then simply
;; thrown away for the garbage collector.
;; This does not matter for our application because we always
;; call remove-preserving-tail with an item that is for sure in
;; the list, but an in-general a safer implementation would save list
;; and return that value rather than returning nil in case the
;; item is unfound.
(defun remove-preserving-tail (item list)
  (if (eql item (car list))
      (cdr list)
    (let ((conc (list nil)))
      (loop for sub on list
	    do (if (eql item (car sub))
		   (progn (lazy-lconc conc (cdr sub))
			  (return-from remove-preserving-tail (car conc)))
		 (lazy-tconc conc (car sub))))
      list)))

;; unused testing function
(defun exhaust-list (done list &key (depth 0))
  (when list
    (format t "~A: ~A~%" depth (list done list))
    (dolist (item list)
      (exhaust-list (cons item done)
		    (remove-preserving-tail item list)
		    :depth (1+ depth)))))

(defun make-sudoku (list)
  (make-array '(9 9)
	      :adjustable nil
	      :initial-contents
	      list))

(dolist (sudoku '(
		  ((- - 2 3 - - 7 - -) 
		   (- - 4 - - 9 - - -) 
		   (6 - - - - - - 5 -) 
		   (- 7 - - - 2 - 6 -) 
		   (- - 3 7 - - 4 - -) 
		   (- 1 - - - - - 2 -) 
		   (- 3 - - - - - - 9) 
		   (- - - 4 - - 6 - -) 
		   (- - 5 - - 8 2 - -))

		  ((4 - 8   3 5 -   1 - -)
		   (- - -   - 1 -   - - 7)
		   (- - -   2 - 4   - - 3)

		   (- 8 -   - - 9   2 - 6)
		   (- - 6   - - -   7 - -)
		   (9 - 3   1 - -   - 5 -)

		   (8 - -   4 - 3   - - -)
		   (7 - -   - 8 -   - - -)
		   (- - 2   - 6 5   4 - 8))



		  
		  (( - - 9 1 8 3 - - 4)
		   ( - - - - - 5 8 2 9)
		   ( 4 8 6 - - - - - -)
		   ( 8 - - - 5 - 3 9 -)
		   ( - 6 - 8 4 9 - 1 -)
		   ( - 9 7 - 2 - - - 8)
		   ( - - - - - - 4 6 7)
		   ( 5 2 1 6 - - - - -)
		   ( 6 - - 9 3 8 2 - -))))
  
  (let ((sudoku (make-sudoku sudoku)))
    (print-sudoku sudoku)
    (time (solve sudoku))))