;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Thu Jan 26 21:14:44 2006 +0530 <enometh@net.meer>
;;;   Time-stamp: <06/02/11 19:55:14 madhu>
;;;   BUGS-To: <enometh@net.meer>
;;;   Version: u060211
;;;
;;;   Status: EXPERIMENTAL/JOKE. DO NOT REDISTRIBUTE
;;;  (C) 2006 Madhu. All Rights Reserved.
;;;
(defpackage "SUDOKU2"
  (:use "CL")
  (:export "SOLVE" "SUDOKU-GRID"))

(in-package "SUDOKU2")

(defclass letter-var-position-mixin ()
  ((xpos :initarg :xpos :type (integer 0 8))
   (ypos :initarg :ypos :type (integer 0 8))))

(defclass letter-var-value-mixin ()
  ((value :initform nil)))		; NOTE NIL indicates wildcard

(defclass letter-var-constraints-mixin () ; NOTE constraints are word-vars
  ((deps
    :documentation "Array of indices of constraints"
    :type (array (integer 0) *)
    :initform (make-array 10 :fill-pointer 0 :adjustable t))
   (positions
    :documentation "Array of indices of constraints"
    :type (array (integer 0) *)
    :initform (make-array 10 :fill-pointer 0 :adjustable t))))

(defclass letter-var (letter-var-position-mixin
		      letter-var-value-mixin
		      letter-var-constraints-mixin)
  ())

(defmethod print-object ((obj letter-var) stream)
  "Print a @[Row,Column] representation"
  (print-unreadable-object (obj stream :type t :identity t)
    (when (every (lambda (x) (slot-boundp obj x)) '(xpos ypos))
      (with-slots (xpos ypos) obj
	(format stream "@[~A,~A]" ypos xpos))
      (if (slot-boundp obj 'value) (write-char #\Space stream)))
    (format stream "~@[~A~]" (if (slot-boundp obj 'value)
				 (slot-value obj 'value)))))

(defclass sudoku-possible-words-mixin ()
  ((values-used)
   (values-remaining)))

(defclass word-var-elements-mixin ()
  ((elem :type (array letter-var *))))

(defclass word-var-canonical-index-mixin ()
  ((canonical-index)))

(defmethod initialize-instance :after ((obj word-var-elements-mixin)
				       &key elements)
  "INTERNAL. ELEMENTS is a sequence of LETTER-VARS"
  (with-slots (elem) obj
    (setf elem (etypecase elements
		 (vector elements)
		 (list (apply 'vector elements))))))

(defclass word-var (sudoku-possible-words-mixin
		    word-var-canonical-index-mixin
		    word-var-elements-mixin)
  ())

(defmethod print-object ((obj word-var) stream)
  (print-unreadable-object (obj stream :type t :identity t)
    (with-slots (canonical-index values-used values-remaining) obj
      (when (slot-boundp obj 'canonical-index)
	(format stream "[~A] " canonical-index))
      (when (slot-boundp obj 'elem)
	(loop for letter-var across (slot-value obj 'elem)
	      for letter-value = (if (slot-boundp letter-var 'value)
				     (slot-value letter-var 'value))
	      do (if letter-value
		     (write letter-value :stream stream)
		     (write-char #\. stream)))
	(write-char #\Space stream))
      (when (slot-boundp obj 'values-used)
	;; (format stream " (~A assigned)" (logcount values-used))
	(when (slot-boundp obj 'values-remaining)
	  (assert (= (+ (logcount values-used)
			(logcount values-remaining))
		     9)))))))

(defclass canonical-word-vars-mixin ()
  ((canonical-words :type (array letter-var *))))

(defmethod init-depwords ((word-var canonical-word-vars-mixin))
  "INTERNAL. Call this function only after initializing the DEPS
  and POSITIONS slots of all letter-vars and after initializing
  the CANONICAL-WORDS slot of OBJ."
  (with-slots (canonical-words) word-var
    (loop for word-var across canonical-words
	  for i from 0
	  do (with-slots (elem canonical-index) word-var
	       (setq canonical-index i)
	       (loop for letter-var across elem
		     for pos from 0
		     do (with-slots (deps positions) letter-var
			  (vector-push-extend i deps)
			  (vector-push-extend pos positions)))))))

(defclass grid-mixin ()
  ((height :type (integer 0))
   (width :type (integer 0))
   (grid :type (array letter-var (* *)))))


;;; ----------------------------------------------------------------------
;;; Sudoku grid
;;;

(defun sudoku-generate-grid ()
  "INTERNAL. Generate an array of LETTER-VARs."
  (make-array '(9 9)
	      :initial-contents
	      (loop for y below 9 collect
		    (loop for x below 9 collect
			  (make-instance 'letter-var
					 :xpos x :ypos y)))))


(defclass sudoku-grid-mixin (grid-mixin) ())

;;;-------+
;;;\    /\|   0    |   1     |   2     |
;;; \  /  +--------+---------+---------+
;;;  \/  /|0  1  2 | 3  4  5 | 6  7  8 |
;;;---+---+--------+---------+---------+
;;;   | 0 |        |         |         |
;;; 0 | 1 |        |         |         |
;;;   | 2 |        |         |         |
;;;---+---+--------+---------+---------+
;;;   | 3 |        |         |         |
;;; 1 | 4 |        |         |         |
;;;   | 5 |        |         |         |
;;;---+---+--------+---------+---------+
;;;   | 6 |        |         |         |
;;; 2 | 7 |        |         |         |
;;;   | 8 |        |         |         |
;;;---+---+--------+---------+---------+

(defmethod sudoku-generate-canonical-word-vars ((obj sudoku-grid-mixin))
  "INTERNAL. Call this method only after initializing the GRID
slot of OBJ. Generate an array of WORD-VARs."
  (with-slots (grid) obj
    (make-array
	   27
	   :initial-contents
	   (nconc
	    (loop for x below 9 collect
		  (make-instance 'word-var
				 :elements
				 (loop for y below 9
				       collect (aref grid x y))))
	    (loop for y below 9 collect
		  (make-instance 'word-var
				 :elements
				 (loop for x below 9
				       collect (aref grid x y))))
	    (list
	     (make-instance 'word-var
			    :elements
			    (loop for x below 3
				  nconc (loop for y below 3
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x from 3 below 6
				  nconc (loop for y below 3
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x from 6 below 9
				  nconc (loop for y below 3
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x below 3
				  nconc (loop for y from 3 below 6
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x from 3 below 6
				  nconc (loop for y from 3 below 6
					      collect (aref grid x y))))

	     (make-instance 'word-var
			    :elements
			    (loop for x from 6 below 9
				  nconc (loop for y from 3 below 6
					      collect (aref grid x y))))

	     (make-instance 'word-var
			    :elements
			    (loop for x below 3
				  nconc (loop for y from 6 below 9
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x from 3 below 6
				  nconc (loop for y from 6 below 9
					      collect (aref grid x y))))
	     (make-instance 'word-var
			    :elements
			    (loop for x from 6 below 9
				  nconc (loop for y from 6 below 9
					      collect (aref grid x y)))))))))


(defmethod initialize-instance :after ((obj sudoku-grid-mixin) &key)
  (with-slots (grid) obj
    (setq grid (sudoku-generate-grid))))

(defvar *pprint-grid* t)

(defmethod print-object ((obj sudoku-grid-mixin) stream)
  (declare (special *pprint-grid*))
    (print-unreadable-object (obj stream :type t :identity t)
  (when *pprint-grid*
      (with-slots (grid) obj
	(if (slot-boundp obj 'grid)
	    (progn
	      (terpri stream)
	      (destructuring-bind (height width) (array-dimensions grid)
		(loop for i below height
		      do (loop for j below width
			    for letter-var = (aref grid i j)
			    for x = (if (slot-boundp letter-var 'value)
					(slot-value letter-var 'value))
			    do (if x
				   (write x :stream stream) ; XXX
				   (write-char #\. stream))
			       (unless (= j (1- width))
				 (if (zerop (mod (1+ j) 3))
				     (write-string " | " stream))
				 (write-char #\Space stream)))
		      (unless (= i (1- height))
			(terpri stream)
			(if (zerop (mod (1+ i) 3))
			    (write-line "------+--------+-------" stream)))))))))))

(defclass sudoku-canonical-word-vars-mixin (canonical-word-vars-mixin) ())

(defmethod initialize-instance :after ((obj sudoku-canonical-word-vars-mixin)
				       &key)
  (with-slots (grid canonical-words) obj ; XXX order of init: grid initialized.
    (setq canonical-words (sudoku-generate-canonical-word-vars obj))
    (init-depwords obj)))

(defclass sudoku-grid (sudoku-canonical-word-vars-mixin	; XXX order
		       sudoku-grid-mixin)
  ())


;;; ----------------------------------------------------------------------
;;;
;;;

(deftype intset () 'integer)

(defun MAKE-EMPTY-INTSET () 0)

(defmacro INTSET-NOT-EMPTY-P (intset)
  `(not (zerop ,intset)))

(defun MAKE-SINGLETON-INTSET (integer)
  (let ((intset 0))
    (setf (ldb (byte 1 integer) intset) 1)
    intset))

(defmacro INTSET-ADD (integer intset)
  "INTSET is a place suitable for (SETF LDB)"
  `(setf (ldb (byte 1 ,integer) ,intset) 1))

(defmacro INTSET-DELETE (integer intset)
  "INTSET is a place suitable [as an arg] for (SETF LDB)"
  `(setf (ldb (byte 1 ,integer) ,intset) 0))

(defmacro INTSET-HAS (intset integer)
  `(not (zerop (ldb (byte 1 ,integer) ,intset))))

(defmacro INTSET-DOES-NOT-HAVE (intset integer)
  `(zerop (ldb (byte 1 ,integer) ,intset)))

(defun INTSET->LIST (intset)
  (loop for integer below (integer-length intset)
	unless (zerop (ldb (byte 1 integer) intset))
	collect integer))

(defmacro INTSET-INTERSECTION (intset1 intset2)
  `(logand ,intset1 ,intset2))

(defvar $1-9 (let ((intset (MAKE-SINGLETON-INTSET 1)))
	       (loop for i from 2 to 9 do (INTSET-ADD i intset))
	       intset))


;;; ----------------------------------------------------------------------
;;;
;;;

(defun init-allowed-word-var (word-var)
  "INTERNAL."
  (with-slots (values-used values-remaining) word-var
    (setf values-used (MAKE-EMPTY-INTSET))
    (setf values-remaining $1-9)))

(defmethod initialize-instance :after ((obj sudoku-possible-words-mixin) &key)
  (init-allowed-word-var obj))

(defun compute-allowed-values (letter-var &optional grid)
  "INTERNAL. return INTSET which represents allowed values of
letter-var (Doesnt check if letter-var is assigned.)"
  (with-slots (deps) letter-var
    (let (ret)
      (loop for i across deps
	    for word-var = (aref (slot-value grid 'canonical-words) i)
	    do (with-slots (values-remaining) word-var
		 (if ret
		     (setq ret (INTSET-INTERSECTION ret values-remaining))
		     (setq ret values-remaining))))
      ret)))

(define-condition dead-end () ())

(define-condition no-allowed-values (dead-end) ())

(defun recompute-closure (word-var-queue &optional grid
			  (letters-visited-p (make-hash-table))
			  (visited-p (make-hash-table)))
  "For each word-var in the set WORD-VAR-QUEUE, for each
  letter-var of word-var if the allowed-values of letter-var has
  changed, ... TODO"
  (let (word-var)
    (loop
       (if (endp word-var-queue)
	   (return (values nil visited-p letters-visited-p)))
       (setq word-var (pop word-var-queue))
       (incf (gethash word-var visited-p 0))
       (loop for letter-var across (slot-value word-var 'elem)
	     for letter-value = (if (slot-boundp letter-var 'value)
				    (slot-value letter-var 'value))
	     for new-allowed-values = (if letter-value
					  (MAKE-SINGLETON-INTSET letter-value)
					  (compute-allowed-values letter-var
								  grid))
	     do
	     (assert (not (zerop new-allowed-values)) nil 'NO-ALLOWED-VALUES)
	     (let ((old-allowed-values (gethash letter-var letters-visited-p)))
	       (cond (old-allowed-values
		      (unless (= old-allowed-values new-allowed-values) ; XXX
			(with-slots (deps) letter-var
			  (loop for i across deps
				for dep-word =
				(aref (slot-value grid 'canonical-words) i)
				unless (gethash dep-word visited-p)
				do (pushnew dep-word word-var-queue)))
			(unless (< (logcount new-allowed-values)
				   (logcount old-allowed-values))
			  (error "convergance failure"))
			(setf (gethash letter-var letters-visited-p)
			      new-allowed-values)))
		     (t (setf (gethash letter-var letters-visited-p)
			      new-allowed-values))))))
    (values T visited-p letters-visited-p)))

(define-condition constraint-violation () ())

(defun notify-word-var (word-var position old-value new-value &key dry-run)
  "Protocol function invoked when the letter-var at POSITION of
WORD-VAR changes from OLD-VALUE to NEW-VALUE"
  (declare (ignorable position))
  (with-slots (values-used values-remaining) word-var
    (when old-value
      (assert (INTSET-HAS values-used old-value) nil 'constraint-violation)
      (assert (INTSET-DOES-NOT-HAVE values-remaining old-value)
	      nil 'constraint-violation))
    (when new-value
      (assert (INTSET-HAS values-remaining new-value) nil
	      'constraint-violation)
      (assert (INTSET-DOES-NOT-HAVE values-used new-value) nil
	      'constraint-violation)
      (when old-value
	(if (= old-value new-value)
	    (return-from notify-word-var NIL)))
      (unless dry-run
	(INTSET-DELETE new-value values-remaining)
	(INTSET-ADD new-value values-used)))
    (unless dry-run
      (when old-value
	(INTSET-ADD old-value values-remaining)
	(INTSET-DELETE old-value values-used)))) T)

(define-condition value-not-allowed (dead-end) ())

(defun set-letter-var (letter-var new-value &optional grid    &key dry-run)
  "INTERNAL. Set the VALUE slot of LETTER-VAR to
NEW-VALUE. Second return value is a set of WORD-VARS impacted by
this change."
  (let ((old-value (if (slot-boundp letter-var 'value)
		       (slot-value letter-var 'value)))
	word-var-queue)
    (cond ((eql new-value old-value)
	   (return-from SET-LETTER-VAR (values T NIL)))
	  (t (when new-value
	       (unless old-value
		 (unless (INTSET-HAS (compute-allowed-values letter-var grid)
				     new-value)
		   (return-from SET-LETTER-VAR NIL))))
	     (unless dry-run
	       (setf (slot-value letter-var 'value) new-value))))
    (with-slots (deps positions) letter-var
      (loop for i across deps
	    for word-var = (aref (slot-value grid 'canonical-words) i)
	    for position across positions
	    for index from 0
	    do (handler-bind ((constraint-violation
			       (lambda (c)
				 (declare (ignore c))
				 (setf (slot-value letter-var 'value)
				       old-value)
				 (loop for j from (1- index) downto 0
				       for undo-word-var =
				       (aref (slot-value grid 'canonical-words)
					     j)
				       for undo-position = (aref positions j)
				       do (notify-word-var undo-word-var
							   undo-position
							   new-value
							   old-value
							   :dry-run dry-run))
				 (return-from set-letter-var NIL))))
		 (when (notify-word-var word-var position old-value new-value
					:dry-run dry-run)
		   ;; word-var is mutated
		   (push word-var word-var-queue)))))
    (values T word-var-queue)))

(defun assign-letter (letter-var value &optional grid
		      (letters-visited-p (make-hash-table)))
  (multiple-value-bind (succeeded-p word-var-queue)
      (set-letter-var letter-var value grid)
    (if word-var-queue
	(recompute-closure word-var-queue grid letters-visited-p)
	succeeded-p)))

(defun unassign-letter (letter-var &optional grid)
  (unless (set-letter-var letter-var NIL grid)
    (error "Unassign letter-var ~A failed." letter-var)))

(defun init-grid (grid &optional (visited-p (make-hash-table)))
  (with-slots (grid canonical-words) grid
    (destructuring-bind (height width) (array-dimensions grid)
      (loop for x below height do
	    (loop for y below width do
		  (let ((letter-var (aref grid x y)))
		    (slot-makunbound letter-var 'value)
		    (map nil (lambda (index)
			       (let ((word-var (aref canonical-words index)))
				 (unless (gethash word-var visited-p)
				   (init-allowed-word-var word-var)
				   (setf (gethash word-var visited-p) t))))
			 (slot-value letter-var 'deps))))))))


(defmethod set-grid-positions ((grid sudoku-grid) (stream stream))
  (init-grid grid)			;XXX
  (loop with lineno = 0
	for x from 0 below 9
	for line = #+nil (read-line stream nil)
	(loop (let ((string (read-line stream nil)))
			   (incf lineno)
			   (unless string (return nil))
			   (when (> (length string) 0)
			     (unless (case (elt string 0)
				       ((#\- #\#) t))
			       (return string)))))
	while line
	do (loop named outer
		 with i = 0 and length = (length line)
		 for y from 0 below 9
		 for letter-var = (aref (slot-value grid 'grid) x y)
		 for c = (loop (unless (< i length) (return-from outer nil))
			    (case (elt line i)
			      ((#\Space #\Tab #\|) (incf i))
			      (otherwise (return (prog1 (elt line i)
						   (incf i))))))
		 do (ecase c
		      (#\. #+nil(unassign-letter letter-var grid))
		      (#\1 (assign-letter letter-var 1 grid))
		      (#\2 (assign-letter letter-var 2 grid))
		      (#\3 (assign-letter letter-var 3 grid))
		      (#\4 (assign-letter letter-var 4 grid))
		      (#\5 (assign-letter letter-var 5 grid))
		      (#\6 (assign-letter letter-var 6 grid))
		      (#\7 (assign-letter letter-var 7 grid))
		      (#\8 (assign-letter letter-var 8 grid))
		      (#\9 (assign-letter letter-var 9 grid))))))


(defmethod set-grid-positions ((grid sudoku-grid) pathname)
  (with-open-file (stream pathname)
    (set-grid-positions grid stream)))


;;; ENTRYPOINT: (MAKE-INSTANCE 'SUDOKU-GRID &KEY PATH)
;;;
;;; PATH is a file or a stream. 
;;;
;;; FILE FORMAT: a 9x9 matrix of digits, one row per line. Each line
;;; can contain spaces and the vertical delimiter `#\|'. Lines
;;; starting with the `#\-' or `#\#' characters are ignored. Empty
;;; lines are ignored.

(defmethod initialize-instance :after ((grid sudoku-grid) &key path)
  (when path (set-grid-positions grid path)))


;;; ----------------------------------------------------------------------
;;;
;;;
#+nil
(defun factorial (n) (if (zerop n) 1 (* n (factorial (1- n)))))

(defun q (m)
  "Return least number whose factorial does not divide M."
  (let ((h 2))
    (loop (multiple-value-bind (f r) (floor m h)
	    (if (zerop r)
		(setq h (1+ h) m f)
		(return h))))))


(defun permutations-f (n f)
  "Call f on a vector containing each permutation of 0,..,N-1."
 (macrolet ((factorial (n)
		`(aref #(1 1 2 6 24 120 720 5040 40320 362880) ,n)))
  (if (zerop n) (return-from permutations-f nil))
  (when (= n 1)
    (funcall f (apply 'vector (loop for i below n collect i)))
     (return-from permutations-f nil))
  (let ((a (apply 'vector (loop for i below n collect i))))
    (funcall f a)
    (let* ((sz (length a))
	   (fact-n (factorial sz))
	   (m 1))
      (loop
	 (rotatef (aref a 0) (aref a 1))
	 (incf m)
	 (funcall f a)
	 (if (= m fact-n) (return))
	 ;;  H is the least number whose factorial does not divide M.
	 (let ((h (q m))
	       (min sz)
	       j)
	   ;; J is the index such that a[J] - a[H] (MOD N) is minimal.
	   (loop for i from 1 to (1- h)
		 for temp = (- (aref a (1- i))
			       (aref a (1- h)))
		 if (< temp 0) do (incf temp sz)
		 if (< temp min) do (setq min temp j i))
	   (decf h)
	   (decf j)
	   (rotatef (aref a h) (aref a j)))
	 (incf m)
	 (funcall f a))))) )


;;; ----------------------------------------------------------------------
;;;
;;;
(defun proxy-indices (word-var)
  "INTERNAL. Indices of the unassigned letter-vars in the ELEM
slot of WORD-VAR. Additional values returned are a vector of the
unassigned letters and their count."
  (loop for i from 0
	for letter-var across (slot-value word-var 'elem)
	for letter-value =  (if (slot-boundp letter-var 'value)
				(slot-value letter-var 'value))
	unless letter-value collect i into proxy-indices
	and collect letter-var into letter-vars
	and count t into length
	finally (return (values proxy-indices (apply 'vector letter-vars)
				length))))

(defun assign-letter-with-undo (letter-var new-value undo-list &optional grid)
  "INTERNAL. Handles NO-ALLOWED-VALUES condition and undo-information"
  (let* ((old-value (if (slot-boundp letter-var 'value)
			(slot-value letter-var 'value)))
	 (cons (assoc letter-var (cdr undo-list))))
    (unless (eql old-value new-value)
      (handler-bind ((no-allowed-values
		      (lambda (c)
			(declare (ignorable c))
			(cond (cons
			       (setf (cdr cons) old-value))
			      (t (push (cons letter-var old-value)
				       (cdr undo-list))))
			(return-from assign-letter-with-undo nil))))
	(prog1 (assign-letter letter-var new-value grid)
	  (cond (cons
		 (setf (cdr cons) old-value))
		(t (push (cons letter-var old-value) (cdr undo-list)))))))))

(defun undo-assigned-letters (undo-list &optional grid)
  (loop for (letter-var . old-value) in (cdr undo-list)
	do (UNASSIGN-LETTER letter-var grid)
	(when old-value
	  (unless (assign-letter letter-var old-value grid)
	    (error "Reset Letter ~A ~A failed" letter-var old-value)))))

(defun assign-word-var (word-var f &optional grid)
  "F is a continuation which is mapped after each successful
assignment of values to the letter-vars of WORD-VAR."
  (with-slots (elem values-remaining) word-var
    ;; the unassigned elements of ELEM will pe permutations of
    ;; the elements of VALUES-REMAINING.
    (multiple-value-bind (proxy-indices proxied-vars n)
	(proxy-indices word-var)
      (when (zerop n)
	(funcall f word-var)
	(return-from assign-word-var NIL))
      (let ((indexed-set (coerce (INTSET->LIST values-remaining) 'vector))
	    (copy (map 'vector (lambda (x)
				 (if (slot-boundp x 'value)
				     (slot-value x 'value)))
		       (slot-value word-var 'elem)))
	    (undo-list (cons nil nil)))
	(labels ((map-fn (indices)	; indices into proxy-indices
		   (loop for v across copy for x across elem ;; XXX HACK
			 unless v
			 when (if (slot-boundp x 'value)
				  (slot-value x 'value))
			 do (UNASSIGN-LETTER x grid))
		   (loop for index across indices
			 for i from 0
			 for proxy-index = (elt proxy-indices index)
			 for letter-var = (elt proxied-vars index)
			 for old-value =  (if (slot-boundp letter-var 'value)
					      (slot-value letter-var 'value))
			 for new-value = (elt indexed-set i)
			 unless (eql new-value old-value)
			 do (unless (ASSIGN-LETTER-WITH-UNDO letter-var
							     new-value
							     undo-list
							     grid)
			      (UNDO-ASSIGNED-LETTERS undo-list grid)
			      (return-from map-fn nil)))
		   (funcall f word-var)))
	  (permutations-f n #'map-fn)
	  (UNDO-ASSIGNED-LETTERS undo-list grid))))))

(defun solve (grid &optional (visited-p (make-hash-table)))
  (with-slots (canonical-words) grid
    (let ((unassigned (coerce canonical-words 'list))
	  (assigned nil))
      (labels ((cmp-words (a b)
		 (let ((la (logcount (slot-value a 'values-remaining)))
		       (lb (logcount (slot-value b 'values-remaining))))
		   (if (= la lb) nil (< la lb)))) ; madhu 060211
	       (pick-next ()
;;;	         #+nil                  ; heuristic
		 (when unassigned
		   (reduce (lambda (a b) (if (cmp-words a b) a b))
			   unassigned))
		 #+nil			; no heuristic
		 (car unassigned))
	       (foo (word-var)
		 (assign-word-var word-var #'bar grid))
	       (bar (word-var)
		 (tagbody
		    (incf (gethash word-var visited-p 0))
		    (push word-var assigned)
		    (setq unassigned (remove word-var unassigned))
		    (let ((x (pick-next)))
		      (unless x
			(cerror "Find another solution" "Solution Found! ~A"
				grid)
			(go undo))
		      (foo x))
		  undo
		    (remhash word-var visited-p)
		    (setq assigned (remove word-var assigned))
		    (push word-var unassigned))))
	(foo (pick-next))))))


#||
(defvar $su (make-instance 'sudoku-grid))
(init-grid $su)
(solve $su)

(with-input-from-string (stream "..41..29.
7.2..9...
6......35
.6.4.7..1
.........
2..6.1.5.
87......4
...3..9.8
.31..65..")
  (set-grid-positions $su stream))

(with-open-file (stream #p"/tmp/z.l" :if-exists :supersede
			:direction :output)
  (pprint $su stream))

;;solution:
"--
3 5 4 |  1 6 8 |  2 9 7
7 1 2 |  5 3 9 |  4 8 6
6 9 8 |  7 2 4 |  1 3 5
------+--------+-------
5 6 3 |  4 9 7 |  8 2 1
1 8 7 |  2 5 3 |  6 4 9
2 4 9 |  6 8 1 |  7 5 3
------+--------+-------
8 7 5 |  9 1 2 |  3 6 4
4 2 6 |  3 7 5 |  9 1 8
9 3 1 |  8 4 6 |  5 7 2
--"

(solve $su)

(setq $z (make-instance 'sudoku-grid :path #p"/tmp/z.l"))
(solve $z)
||#