nfunato/sudoku.lisp

## sudoku.lisp
;;;
;;; Yet another porting of Dr. Norvig's Sudoku Solver, in Common Lisp
;;;
;;;                                                   @nfunato 2017-12-31

;;; Please see the original article (http://norvig.com/sudoku.html) for detail.

;;; Note
;;;
;;;  - I intentionally tried to keep the smell of the original code, except
;;;    idiom definitions and a heuristics -- the latter of which is the heart
;;;    of this code. Some execution logs and my comment are at the foot.
;;;
;;;  - Haskell-like type annotations are added for some functions.
;;;    In fact, this code was originally written six years ago for validating
;;;    Haskell code (https://git.io/vbxs1), when I did self-studying Haskell.

;;;===================================================================
;;; Modestly common idioms

(defun check-length (n xs)
  (assert (= n (length xs))))

(defun set-equal (s1 s2)
  (and (subsetp s1 s2 :test #'equal)
       (subsetp s2 s1 :test #'equal)))

(defmacro acond (&rest cls)
  (if (null cls) nil
    (let ((cl1 (car cls)) (sym (gensym)))
      `(let ((,sym ,(car cl1)))
         (if ,sym
           (let ((it ,sym)) (declare (ignorable it)) ,@(cdr cl1))
             (acond ,@(cdr cls)))))))

(defmacro aprog1 (f . fs) `(let ((it ,f)) ,@fs it))
(defun filter     (f  xs) (remove-if-not f xs))
(defun rcurry     (f  b)  (lambda (a) (funcall f a b)))
(defun lcurry     (f  a)  (lambda (b) (funcall f a b)))
(defun lcurry*    (f  a)  (lambda (&rest r) (apply f a r)))
(defun zip        (xs ys) (map 'list #'cons xs ys))
(defun k-zip      (x  ys) (map 'list (lcurry #'cons x) ys))
(defun zip-k      (xs y)  (map 'list (rcurry #'cons y) xs))

(defun foldM (f z xs)   ; Maybe m => (a -> b -> m a) -> a -> [b] -> m a
  (flet ((g (acc v)
           (when (null acc) (return-from foldM nil))
           (funcall f acc v)))
    (reduce #'g xs :initial-value z)))

(defmacro dict ((key val) keys)
  `(aprog1 (make-hash-table :test #'equal)
           (mapc (lambda (,key) (setf (gethash ,key it) ,val))
                 ,keys)))

(defun dict-copy (ht)   ; you can use alexandria:copy-hash-table instead of it
  (loop with ht2 = (make-hash-table :test (hash-table-test ht))
        for k being the hash-keys in ht
        using (hash-value v)
        do (setf (gethash k ht2) v)
        finally (return ht2)))

(defun dict-get (ht key &optional (error-ctrl nil ec-sup) default)
  (or (gethash key ht)
      (if (and ec-sup (null error-ctrl))
          default
          (error error-ctrl))))

(defun dict-set! (ht val key)
  (setf (gethash key ht) val)
  ht)

(defun dict-set (ht val key)
  (dict-set! (dict-copy ht) val key))

(defun dict-items (ht &key (test (constantly t)))
  (loop for k being the hash-keys in ht using (hash-value v)
        when (funcall test k v) collect (cons k v)))

(defun groups-of (n lst)
  (unless (plusp n) (error "Groups-Of"))
  (labels ((take (m xs) (loop repeat m for x in xs collect x))
           (rec (acc xs)
             (if (null xs)
                 (nreverse acc)
                 (rec (cons (take n xs) acc) (nthcdr n xs)))))
    (rec '() lst)))

(defun join (sep xs)
  (format nil "~{~a~#,1^~a~}" (mapcan (lambda (x) (list x sep)) xs)))

(defun concat (strings)
  (apply #'concatenate 'string strings))

(defun shuffle-vector (vec)     ; Fisher-Yates shuffle
  (loop for i from (1- (length vec)) downto 1
        for j = (random (1+ i))
        do (rotatef (aref vec i) (aref vec j))
        finally (return vec)))

(defun shuffle-list (lst)
  (coerce (shuffle-vector (coerce lst 'simple-vector)) 'list))

;;;===================================================================
;;; Tables

(defvar +digits+ "123456789")
(defvar +rows+   "ABCDEFGHI")
(defvar +cols+   +digits+)

;; String -> String -> [String]
(defun cp (xs ys)       ; Compute cartesian product
  (loop for x across xs nconc
    (loop for y across ys collect (concatenate 'string (list x y)))))

(defvar +squares+ (cp +rows+ +cols+))

(defvar +units+
  (nconc (loop for c across +cols+ collect (cp +rows+ (string c)))
         (loop for r across +rows+ collect (cp (string r) +cols+))
         (loop for rs in '("ABC" "DEF" "GHI") nconc
           (loop for cs in '("123" "456" "789") collect (cp rs cs)))))

(defun sq-eql (sq1 sq2) (string= sq1 sq2))
(defun sq-mem (sq  sqs) (find sq sqs :test #'sq-eql))
(defun sq-rem (sq  sqs) (remove sq sqs :test #'sq-eql))
(defun sq-remdup  (sqs) (remove-duplicates sqs :test #'sq-eql))
(defun sq-pos (sq  sqs) (position sq sqs :test #'sq-eql))

(defvar +units-map+
  (dict (sq (filter (lcurry #'sq-mem sq) +units+))
        +squares+))

(defvar +peers-map+
  (dict (sq (sq-rem sq (sq-remdup (apply #'append (dict-get +units-map+ sq)))))
        +squares+))

(defun units-of (sq) (dict-get +units-map+ sq "Units-Of"))
(defun peers-of (sq) (dict-get +peers-map+ sq "Peers-Of"))

(defun test-tables ()
  "Do a set of unit tests."
  (check-length 81 +squares+)
  (check-length 27 +units+)
  (mapc (lambda (sq) (check-length  3 (units-of sq))) +squares+)
  (mapc (lambda (sq) (check-length 20 (peers-of sq))) +squares+)
  (assert (set-equal (units-of "C2")
                     '(("A2" "B2" "C2" "D2" "E2" "F2" "G2" "H2" "I2")
                       ("C1" "C2" "C3" "C4" "C5" "C6" "C7" "C8" "C9")
                       ("A1" "A2" "A3" "B1" "B2" "B3" "C1" "C2" "C3"))))
  (assert (set-equal (peers-of "C2")
                     '("A2" "B2" "D2" "E2" "F2" "G2" "H2" "I2"
                       "C1" "C3" "C4" "C5" "C6" "C7" "C8" "C9"
                       "A1" "A3" "B1" "B3")))
  (princ "All tests pass.")
  (terpri))

;;;===================================================================
;;; Parser

;; String -> Map Sq String, where length of String is either 1 or 0.
(defun grid-values (grid)
  (let ((chars
          (loop for c across grid
                when (or (find c +digits+) (if (find c "0.") "")) collect it)))
    (check-length 81 chars)
    (dict (sq (string (elt chars (sq-pos sq +squares+))))
          +squares+)))

(defvar +initial-values+ (dict (sq +digits+) +squares+))

(defun moves-for-grid (grid)
  (loop for sq being the hash-keys in (grid-values grid) using (hash-value str)
        do (assert (<= (length str) 1))
        when (string/= "" str) collect (cons sq (elt str 0))))

;; String -> Maybe Values, where type Values = Map Sq [Digit]
(defun parse-grid (grid)
  (foldM #'assign (dict-copy +initial-values+) (moves-for-grid grid)))

;;;===================================================================
;;; Solver

;; Values -> Move -> Maybe Values, where type Move = (Sq, Digit)
(defun assign (values move)
  (destructuring-bind (sq . d) move
    (foldM #'eliminate values (k-zip sq (remove d (dict-get values sq))))))

;; Values -> Move -> Maybe Values
(defun eliminate (values move)
  (destructuring-bind (sq . d) move
    (let ((digits (dict-get values sq)))
      (if (not (find d digits))
          values
          (let ((digits2 (remove d digits)))
            (foldM (lcurry* #'place d)
                   (case (length digits2)
                     (0 nil)
                     (1 (foldM #'eliminate
                               (dict-set! values digits2 sq)
                               (zip-k (peers-of sq) (elt digits2 0))))
                     (t (dict-set! values digits2 sq)))
                   (units-of sq)))))))

;; Digit -> Values -> Unit -> Maybe Values
(defun place (d values unit)
  (let ((sqs (filter (lambda (sq) (find d (dict-get values sq))) unit)))
    (cond ((null sqs)       nil)
          ((null (cdr sqs)) (assign values (cons (car sqs) d)))
          (t                values))))

;;;===================================================================
;;; Unparser

(defun values-string (vals)
  (let* ((w (1+ (loop for v being the hash-values in vals maximize (length v))))
         (hl (make-string (1+ (* 3 w)) :initial-element #\-))
         (brk (format nil "~a+~a+~a~%" hl hl hl)))
    (flet ((sq-str (sq &aux (d (dict-get vals sq)))
             (format nil "~v,a" w (if (string= d "") "." d))))
      (join brk
        (mapcar (lambda (xs) (format nil "~{ ~a| ~a| ~a~%~}" xs))
          (groups-of 9
            (loop for sqs in (groups-of 3 +squares+) collect
              (concat (mapcar #'sq-str sqs)))))))))

(defun display (maybe-values &optional (st *standard-output*))
  (when maybe-values
    (format st (values-string maybe-values))
    (finish-output st)))

;;;===================================================================
;;; Explorer

(defparameter *use-heuristics-p* nil
  "A flag to switch whether or not to use a heuristics to select next moves.")

(defun analyze-values (values)
  "Analyze the current board status, i.e. VALUES. Return (T NIL) if a solution is found, otherwise return (NIL POSSIBLE-NEXT-MOVES). If *USE-HEURISTICS-P* is off, the explorer behaves essentially same with the original python code. However if the flag is on, a heuristics defined below is applied, and it tries to select next moves for pruning search space better."
  (loop with best-len = 10
        with best-ds = nil
        with best-sq = nil
        for sq being the hash-keys in values using (hash-value ds)
        for len = (length ds)
        do (assert (plusp len))
        when (or (< 1 len best-len)
                 (and *use-heuristics-p*
                      (< 1 len) (= len best-len)
                      (better-by-heuristics sq best-sq len values)))
          do (setf best-len len best-sq sq best-ds ds)
        minimize len into min-len
        maximize len into max-len
        finally (return
                  (if (= 1 min-len max-len)
                      (values t nil)
                      (progn
                        (assert best-sq)
                        (values nil (k-zip best-sq best-ds)))))))

(defvar *new-board-count* nil
  "A counter for counting new board generation.")

;; Maybe Values -> Maybe Values
(defun search-values (vals)
  (labels ((rec (v rest)
             (cond ((and (null v) (null rest))
                    nil)
                   ((null v)
                    (incf *new-board-count*)
                    (destructuring-bind ((v2 . m2) . rest2) rest
                      (rec (assign (dict-copy v2) m2) rest2)))
                   (t
                    (multiple-value-bind (solved? moves) (analyze-values v)
                      (if solved? v (rec nil (nconc (k-zip v moves) rest))))))))
    (setf *new-board-count* 0)
    (rec vals '())))

(defvar *print-new-board-count-p* nil)

;; String -> Maybe Values
(defun solve (grid &optional (print *print-new-board-count-p*))
  "Search a solution for a given GRID."
  (prog1 (search-values (parse-grid grid))
    (when print (format t "~&Board count = ~d~%" *new-board-count*))))

;;;
;;; Heuristics for Explorer
;;;

(defun better-by-heuristics (sq1 sq2 len values)
  "When the lengths in values[sq1] and values[sq2] are equal, judge which SQ is better for the next SQ candidate based on a heuristics. Return T if SQ1 is better than SQ2, otherwise NIL."
  (flet ((point> (hp1 hp2)
           ;; The heuristics is:
           ;;  1. take SQ, one of whose PEER having the least length value LEN
           ;;  2. if LEN of SQ1 and SQ2 are same, take SQ having many PEER
           ;;  3. if NUM of SQ1 and SQ2 are same, take SQ having small total LEN
           (destructuring-bind ((len1 . num1) . sum1) hp1
             (destructuring-bind ((len2 . num2) . sum2) hp2
               (cond ((= len1 len2)
                      (if (= num1 num2) (< sum1 sum2) (> num1 num2)))
                     (t (< len1 len2)))))))
    ;; note: we don't cache a survived hp for next comparison for simplicity
    (point> (heurestics-point sq1 len values)
            (heurestics-point sq2 len values))))

(defun heurestics-point (sq len values)
  (let* ((v1 (remove-if (rcurry #'< len)
               (sort (mapcar (lambda (p) (length (dict-get values p)))
                             (peers-of sq))
                     #'<)))
         (v2 (run-length-encode v1))
         (v3 (apply #'+ v1)))
    (assert (and (consp v2) (consp (car v2))))
    (assert (integerp v3))
    (cons (car v2) v3)))

(defun run-length-encode (sorted-lst)
  "Compute run-length encoding of SORTED-LST, e.g. return ((A . 4) (B . 1) (C . 2) for (A A A A B C C)."
  (flet ((pack (lst)
           (nreverse
            (reduce (lambda (acc x)
                      (cond ((null acc)           (list (list x)))
                            ((equal (caar acc) x) (cons (cons x (car acc))
                                                        (cdr acc)))
                            (t                    (cons (list x) acc))))
                    lst
                    :initial-value '()))))
    (mapcar (lambda (x) (cons (car x) (length x)))
            (pack sorted-lst))))

;;;===================================================================
;;; System test

(defun solve-all (grids &optional (name "") (show-if 0.0))
  (flet ((sum (xs) (apply #'+ xs))
         (time-solve (grid)
           (let* ((start  (get-internal-real-time))
                  (values (solve grid))
                  (end    (get-internal-real-time))
                  (time   (/ (coerce (- end start) 'float)
                             internal-time-units-per-second)))
             ;; Display puzzles that take long enough
             (when (and (numberp show-if) (> time show-if))
               (display (grid-values grid))
               (format t "~&Board count = ~d~%" *new-board-count*)
               (display values)
               (format t "(~f seconds)~%" time))
             (list time (solved values)))))
    (multiple-value-bind (times results)
        (loop for grid in grids
              for (time result) = (time-solve grid)
              collect time into times
              collect (if result 1 0) into results
              finally (return (values times results)))
      (let ((n (length grids)))
        (when (> n 1)
          (format t
            "Solved ~d of ~d ~7a puzzles ~
             (avg ~,3f secs (~3d Hz), max ~,3f secs).~%"
            (sum results) n name
            (floor (sum times) n) (floor n (sum times))
            (apply #'max times)))))))

(defun solved (values)
  (flet ((unit-solved (u)
           (equal +digits+
                  (sort (concat (loop for sq in u collect (dict-get values sq)))
                        #'char<))))
    (if (and values (every #'unit-solved +units+))
        values)))

(defun from-file (path &aux (eof (cons nil nil)))
  (with-open-file (st path :direction :input)
    (loop for l = (read-line st nil eof) until (eq l eof) collect l)))

(defun to-file (grids &optional (path #p"./problems/random.txt"))
  (with-open-file (st path :direction :output :if-exists :overwrite)
    (loop for gr in grids do
      (format st "~a~%" gr))))

(defun values-grid (values)
  (flet ((fn (sq &aux (ds (dict-get values sq)))
           (if (= 1 (length ds)) (elt ds 0) #\.)))
    (map 'string #'fn +squares+)))

(defun random-puzzle (&optional (n 17))
  (labels ((random-move (vals sq &aux (ds (dict-get vals sq)))
             (cons sq (elt ds (random (length ds)))))
           (complete? (vals)
             (let ((ds (loop for v being the hash-values in vals
                             when (= 1 (length v)) collect v)))
               (and (<= n (length ds))
                    (<= 8 (length (remove-duplicates ds :test #'equal))))))
           (lp (vals sqs)
             (acond ((null sqs)         ; restart
                     (make-one-puzzle))
                    ((assign (dict-copy vals) (random-move vals (car sqs)))
                     (when (complete? it)
                       (return-from random-puzzle (values-grid it)))
                     (lp it (cdr sqs)))
                    (t
                     (lp vals (cdr sqs)))))
           (make-one-puzzle ()
             (lp (dict (sq +digits+) +squares+) (shuffle-list +squares+))))
    (make-one-puzzle)))

(defun random-puzzles (number path &optional (n-assign 17))
  (if (and (probe-file path)
           (null (y-or-n-p "Create a new version of ~A?" path)))
      (from-file path)
      (loop with pool = '()
            for grid = (random-puzzle n-assign)
            for item = (cons (sxhash grid) grid)
            for count = (if (find item pool :test #'equal) 0 1)
            for total = count then (+ total count)
            do (when (= count 1) (push item pool))
            while (< total number)
            finally (return
                      (aprog1 (mapcar #'cdr pool)
                              (to-file it path))))))

(defun system-test ()
  (test-tables)
  (solve-all (from-file #p"./problems/easy50.txt")     "easy"    0.1)
  (solve-all (from-file #p"./problems/top95.txt")      "hard"    0.1)
  (solve-all (from-file #p"./problems/hardest.txt")    "hardest" 0.1)
; (solve-all (random-puzzles 99 #p"./problems/random.txt") "random"  0.1)
  )

;;;===================================================================
;;; Some test data

(defvar *grid1*
  "00302060090030500100180640000810290070000
   0008006708200002609500800203009005010300")

(defvar *grid2*
  "4.....8.5.3..........7......2.....6.....8
   .4......1.......6.3.7.5..2.....1.4......")

(defvar *grid3*
  ". . 5 | 3 . . | . . .
   8 . . | . . . | . 2 .
   . 7 . | . 1 . | 5 . .
   ------+-------+------
   4 . . | . . 5 | 3 . .
   . 1 . | . 7 . | . . 6
   . . 3 | 2 . . | . 8 .
   ------+-------+------
   . 6 . | 5 . . | . . 9
   . . 4 | . . . | . 3 .
   . . . | . . 9 | 7 . .")

(defvar *hard1*
  ".....6....59.....82....8....45..0.....3..
   ..0...6..3.54...325..6..................")

;;;===================================================================
;;; Some log records
;;;
;;;  - No.1 Solving *hard1* w/ and w/o heuristics in CCL64
;;;  - No.2 ditto, but in SBCL
;;;  - No.3 Executing system-test w/ and w/o heuristics in SBCL
;;;
;;;  As for No.1 and No.2, you can see that the problem *hard1* is
;;;  also hard for SBCL, as in the original python case, but not hard
;;;  for CCL64 when *use-heuristics-p* is NIL. (I think it makes sense
;;;  because natural scanning order for hashtable is CL-implementation
;;;  dependent.)
;;;  At the same time, setting *use-heuristics-p* to T speeds up *hard1*
;;;  case for SBCL. I expect the heuristics averaging some prominently
;;;  time-consuming cases without exception.

#| No.1
CL-USER> (lisp-implementation-type)
"Clozure Common Lisp"
CL-USER> (lisp-implementation-version)
"Version 1.11-r16635  (DarwinX8664)"
CL-USER> (display (grid-values *hard1*))
 . . . | . . 6 | . . .
 . 5 9 | . . . | . . 8
 2 . . | . . 8 | . . .
-------+-------+-------
 . 4 5 | . . . | . . .
 . . 3 | . . . | . . .
 . . 6 | . . 3 | . 5 4
-------+-------+-------
 . . . | 3 2 5 | . . 6
 . . . | . . . | . . .
 . . . | . . . | . . .
NIL
CL-USER> (setf *use-heuristics-p* nil)
NIL
CL-USER> (time (display (solve *hard1* t)))
Board count = 33
 3 8 7 | 5 4 6 | 9 2 1
 4 5 9 | 2 3 1 | 6 7 8
 2 6 1 | 9 7 8 | 5 4 3
-------+-------+-------
 7 4 5 | 6 1 2 | 3 8 9
 8 2 3 | 4 5 9 | 1 6 7
 9 1 6 | 7 8 3 | 2 5 4
-------+-------+-------
 1 7 4 | 3 2 5 | 8 9 6
 6 3 2 | 8 9 7 | 4 1 5
 5 9 8 | 1 6 4 | 7 3 2
(DISPLAY (SOLVE *HARD1* T))
took 24,051 microseconds (0.024051 seconds) to run.
      1,292 microseconds (0.001292 seconds, 5.37%) of which was spent in GC.
During that period, and with 4 available CPU cores,
     22,115 microseconds (0.022115 seconds) were spent in user mode
      1,863 microseconds (0.001863 seconds) were spent in system mode
 991,296 bytes of memory allocated.
 96 minor page faults, 2 major page faults, 0 swaps.
NIL
CL-USER> (setf *use-heuristics-p* t)
T
CL-USER> (time (display (solve *hard1* t)))
Board count = 24
 8 7 4 | 1 3 6 | 5 2 9
 6 5 9 | 2 7 4 | 3 1 8
 2 3 1 | 9 5 8 | 4 6 7
-------+-------+-------
 9 4 5 | 7 6 2 | 8 3 1
 7 8 3 | 5 4 1 | 6 9 2
 1 2 6 | 8 9 3 | 7 5 4
-------+-------+-------
 4 1 7 | 3 2 5 | 9 8 6
 5 6 2 | 4 8 9 | 1 7 3
 3 9 8 | 6 1 7 | 2 4 5
(DISPLAY (SOLVE *HARD1* T))
took 21,695 microseconds (0.021695 seconds) to run.
During that period, and with 4 available CPU cores,
     20,478 microseconds (0.020478 seconds) were spent in user mode
        987 microseconds (0.000987 seconds) were spent in system mode
 1,098,288 bytes of memory allocated.
NIL
|#

#| No.2
CL-USER> (lisp-implementation-type)
"SBCL"
CL-USER> (lisp-implementation-version)
"1.4.1"
CL-USER> (display (grid-values *hard1*))
 . . . | . . 6 | . . .
 . 5 9 | . . . | . . 8
 2 . . | . . 8 | . . .
-------+-------+-------
 . 4 5 | . . . | . . .
 . . 3 | . . . | . . .
 . . 6 | . . 3 | . 5 4
-------+-------+-------
 . . . | 3 2 5 | . . 6
 . . . | . . . | . . .
 . . . | . . . | . . .
NIL
CL-USER> (setf *use-heuristics-p* nil)
NIL
CL-USER> (time (display (solve *hard1* t)))
Board count = 658725
 4 3 8 | 7 9 6 | 2 1 5
 6 5 9 | 1 3 2 | 4 7 8
 2 7 1 | 4 5 8 | 6 9 3
-------+-------+-------
 8 4 5 | 2 1 9 | 3 6 7
 7 1 3 | 5 6 4 | 8 2 9
 9 2 6 | 8 7 3 | 1 5 4
-------+-------+-------
 1 9 4 | 3 2 5 | 7 8 6
 3 6 2 | 9 8 7 | 5 4 1
 5 8 7 | 6 4 1 | 9 3 2
Evaluation took:
  95.807 seconds of real time
  95.413642 seconds of total run time (94.477152 user, 0.936490 system)
  [ Run times consist of 1.799 seconds GC time, and 93.615 seconds non-GC time. ]
  99.59% CPU
  153,293,840,806 processor cycles
  12,912,792,592 bytes consed

NIL
CL-USER> (setf *use-heuristics-p* t)
T
CL-USER> (time (display (solve *hard1* t)))
Board count = 22
 8 7 4 | 2 3 6 | 1 9 5
 6 5 9 | 1 7 4 | 3 2 8
 2 3 1 | 9 5 8 | 4 6 7
-------+-------+-------
 9 4 5 | 6 1 7 | 8 3 2
 7 8 3 | 5 4 2 | 6 1 9
 1 2 6 | 8 9 3 | 7 5 4
-------+-------+-------
 4 1 7 | 3 2 5 | 9 8 6
 3 6 2 | 7 8 9 | 5 4 1
 5 9 8 | 4 6 1 | 2 7 3
Evaluation took:
  0.014 seconds of real time
  0.013941 seconds of total run time (0.013793 user, 0.000148 system)
  100.00% CPU
  22,212,941 processor cycles
  1,143,680 bytes consed

NIL
|#

#| No.3
CL-USER> (lisp-implementation-type)
"SBCL"
CL-USER> (lisp-implementation-version)
"1.4.1"
CL-USER> (setf *use-heuristics-p* nil)
NIL
CL-USER> (system-test)
All tests pass.
Solved 50 of 50 easy    puzzles (avg 0.000 secs (131 Hz), max 0.012 secs).
Solved 95 of 95 hard    puzzles (avg 0.000 secs ( 43 Hz), max 0.120 secs).
Solved 11 of 11 hardest puzzles (avg 0.000 secs (102 Hz), max 0.013 secs).
NIL
CL-USER> (setf *use-heuristics-p* t)
T
CL-USER> (system-test)
All tests pass.
Solved 50 of 50 easy    puzzles (avg 0.000 secs (134 Hz), max 0.016 secs).
Solved 95 of 95 hard    puzzles (avg 0.000 secs ( 46 Hz), max 0.107 secs).
Solved 11 of 11 hardest puzzles (avg 0.000 secs (119 Hz), max 0.012 secs).
NIL
|#

## the-worlds-hardest-problem-log.txt
;;;; Solving a problem specified in https://gigazine.net/news/20100822_hardest_sudoku/ (2010-08-22)

CL-USER> (defparameter *hardest-in-the-world*
	   "..53..... 8......2. .7..1.5.. 4....53.. .1..7...6 ..32...8. .6.5....9 ..4....3. .....97..")
*HARDEST-IN-THE-WORLD*
CL-USER> (display (grid-values *hardest-in-the-world*))
 . . 5 | 3 . . | . . .
 8 . . | . . . | . 2 .
 . 7 . | . 1 . | 5 . .
-------+-------+-------
 4 . . | . . 5 | 3 . .
 . 1 . | . 7 . | . . 6
 . . 3 | 2 . . | . 8 .
-------+-------+-------
 . 6 . | 5 . . | . . 9
 . . 4 | . . . | . 3 .
 . . . | . . 9 | 7 . .
NIL
CL-USER> (lisp-implementation-type)
"SBCL"
CL-USER> (lisp-implementation-version)
"2.0.0"
CL-USER> (setf *use-heuristics-p* nil)
NIL
CL-USER> (time (display (solve *hardest-in-the-world* t)))
Board count = 21
 1 4 5 | 3 2 7 | 6 9 8
 8 3 9 | 6 5 4 | 1 2 7
 6 7 2 | 9 1 8 | 5 4 3
-------+-------+-------
 4 9 6 | 1 8 5 | 3 7 2
 2 1 8 | 4 7 3 | 9 5 6
 7 5 3 | 2 9 6 | 4 8 1
-------+-------+-------
 3 6 7 | 5 4 2 | 8 1 9
 9 8 4 | 7 6 1 | 2 3 5
 5 2 1 | 8 3 9 | 7 6 4
Evaluation took:
  0.011 seconds of real time
  0.011738 seconds of total run time (0.011618 user, 0.000120 system)
  109.09% CPU
  23,388,297 processor cycles
  1,080,208 bytes consed

NIL
CL-USER> (setf *use-heuristics-p* t)
T
CL-USER> (time (display (solve *hardest-in-the-world* t)))
Board count = 8
 1 4 5 | 3 2 7 | 6 9 8
 8 3 9 | 6 5 4 | 1 2 7
 6 7 2 | 9 1 8 | 5 4 3
-------+-------+-------
 4 9 6 | 1 8 5 | 3 7 2
 2 1 8 | 4 7 3 | 9 5 6
 7 5 3 | 2 9 6 | 4 8 1
-------+-------+-------
 3 6 7 | 5 4 2 | 8 1 9
 9 8 4 | 7 6 1 | 2 3 5
 5 2 1 | 8 3 9 | 7 6 4
Evaluation took:
  0.006 seconds of real time
  0.005804 seconds of total run time (0.005793 user, 0.000011 system)
  100.00% CPU
  11,578,316 processor cycles
  752,960 bytes consed

NIL

;;;; Another difficult problem for human in http://qiita.com/yumura_s/items/4e759467d64f7a0cb335
;;;; Is this the true most difficult sudoku problem by a Finnish mathematician?
;;;; ( Unfortunately our heuristics slows down the elapsed time a bit :-| )

CL-USER> (defparameter *hardest-in-the-world-2*
	   "8..........36......7..9.2...5...7.......457.....1...3...1....68..85...1..9....4..")
*HARDEST-IN-THE-WORLD-2*
CL-USER> (display (grid-values *hardest-in-the-world-2*))
 8 . . | . . . | . . .
 . . 3 | 6 . . | . . .
 . 7 . | . 9 . | 2 . .
-------+-------+-------
 . 5 . | . . 7 | . . .
 . . . | . 4 5 | 7 . .
 . . . | 1 . . | . 3 .
-------+-------+-------
 . . 1 | . . . | . 6 8
 . . 8 | 5 . . | . 1 .
 . 9 . | . . . | 4 . .
NIL
CL-USER> (time (display (solve *hardest-in-the-world-2* t)))
Board count = 172
 8 1 2 | 7 5 3 | 6 4 9
 9 4 3 | 6 8 2 | 1 7 5
 6 7 5 | 4 9 1 | 2 8 3
-------+-------+-------
 1 5 4 | 2 3 7 | 8 9 6
 3 6 9 | 8 4 5 | 7 2 1
 2 8 7 | 1 6 9 | 5 3 4
-------+-------+-------
 5 2 1 | 9 7 4 | 3 6 8
 4 3 8 | 5 2 6 | 9 1 7
 7 9 6 | 3 1 8 | 4 5 2
Evaluation took:
  0.046 seconds of real time
  0.046235 seconds of total run time (0.038801 user, 0.007434 system)
  100.00% CPU
  92,229,646 processor cycles
  5,132,800 bytes consed

NIL
CL-USER> (setf *use-heuristics-p* t)
T
CL-USER> (time (display (solve *hardest-in-the-world-2* t)))
Board count = 186
 8 1 2 | 7 5 3 | 6 4 9
 9 4 3 | 6 8 2 | 1 7 5
 6 7 5 | 4 9 1 | 2 8 3
-------+-------+-------
 1 5 4 | 2 3 7 | 8 9 6
 3 6 9 | 8 4 5 | 7 2 1
 2 8 7 | 1 6 9 | 5 3 4
-------+-------+-------
 5 2 1 | 9 7 4 | 3 6 8
 4 3 8 | 5 2 6 | 9 1 7
 7 9 6 | 3 1 8 | 4 5 2
Evaluation took:
  0.062 seconds of real time
  0.062310 seconds of total run time (0.058274 user, 0.004036 system)
  100.00% CPU
  124,314,580 processor cycles
  7,629,296 bytes consed

NIL
CL-USER>
	;;;
	;;; Yet another porting of Dr. Norvig's Sudoku Solver, in Common Lisp
	;;;
	;;; @nfunato 2017-12-31

	;;; Please see the original article (http://norvig.com/sudoku.html) for detail.

	;;; Note
	;;;
	;;; - I intentionally tried to keep the smell of the original code, except
	;;; idiom definitions and a heuristics -- the latter of which is the heart
	;;; of this code. Some execution logs and my comment are at the foot.
	;;;
	;;; - Haskell-like type annotations are added for some functions.
	;;; In fact, this code was originally written six years ago for validating
	;;; Haskell code (https://git.io/vbxs1), when I did self-studying Haskell.

	;;;===================================================================
	;;; Modestly common idioms

	(defun check-length (n xs)
	(assert (= n (length xs))))

	(defun set-equal (s1 s2)
	(and (subsetp s1 s2 :test #'equal)
	(subsetp s2 s1 :test #'equal)))

	(defmacro acond (&rest cls)
	(if (null cls) nil
	(let ((cl1 (car cls)) (sym (gensym)))
	`(let ((,sym ,(car cl1)))
	(if ,sym
	(let ((it ,sym)) (declare (ignorable it)) ,@(cdr cl1))
	(acond ,@(cdr cls)))))))

	(defmacro aprog1 (f . fs) `(let ((it ,f)) ,@fs it))
	(defun filter (f xs) (remove-if-not f xs))
	(defun rcurry (f b) (lambda (a) (funcall f a b)))
	(defun lcurry (f a) (lambda (b) (funcall f a b)))
	(defun lcurry* (f a) (lambda (&rest r) (apply f a r)))
	(defun zip (xs ys) (map 'list #'cons xs ys))
	(defun k-zip (x ys) (map 'list (lcurry #'cons x) ys))
	(defun zip-k (xs y) (map 'list (rcurry #'cons y) xs))

	(defun foldM (f z xs) ; Maybe m => (a -> b -> m a) -> a -> [b] -> m a
	(flet ((g (acc v)
	(when (null acc) (return-from foldM nil))
	(funcall f acc v)))
	(reduce #'g xs :initial-value z)))

	(defmacro dict ((key val) keys)
	`(aprog1 (make-hash-table :test #'equal)
	(mapc (lambda (,key) (setf (gethash ,key it) ,val))
	,keys)))

	(defun dict-copy (ht) ; you can use alexandria:copy-hash-table instead of it
	(loop with ht2 = (make-hash-table :test (hash-table-test ht))
	for k being the hash-keys in ht
	using (hash-value v)
	do (setf (gethash k ht2) v)
	finally (return ht2)))

	(defun dict-get (ht key &optional (error-ctrl nil ec-sup) default)
	(or (gethash key ht)
	(if (and ec-sup (null error-ctrl))
	default
	(error error-ctrl))))

	(defun dict-set! (ht val key)
	(setf (gethash key ht) val)
	ht)

	(defun dict-set (ht val key)
	(dict-set! (dict-copy ht) val key))

	(defun dict-items (ht &key (test (constantly t)))
	(loop for k being the hash-keys in ht using (hash-value v)
	when (funcall test k v) collect (cons k v)))

	(defun groups-of (n lst)
	(unless (plusp n) (error "Groups-Of"))
	(labels ((take (m xs) (loop repeat m for x in xs collect x))
	(rec (acc xs)
	(if (null xs)
	(nreverse acc)
	(rec (cons (take n xs) acc) (nthcdr n xs)))))
	(rec '() lst)))

	(defun join (sep xs)
	(format nil "~{~a~#,1^~a~}" (mapcan (lambda (x) (list x sep)) xs)))

	(defun concat (strings)
	(apply #'concatenate 'string strings))

	(defun shuffle-vector (vec) ; Fisher-Yates shuffle
	(loop for i from (1- (length vec)) downto 1
	for j = (random (1+ i))
	do (rotatef (aref vec i) (aref vec j))
	finally (return vec)))

	(defun shuffle-list (lst)
	(coerce (shuffle-vector (coerce lst 'simple-vector)) 'list))

	;;;===================================================================
	;;; Tables

	(defvar +digits+ "123456789")
	(defvar +rows+ "ABCDEFGHI")
	(defvar +cols+ +digits+)

	;; String -> String -> [String]
	(defun cp (xs ys) ; Compute cartesian product
	(loop for x across xs nconc
	(loop for y across ys collect (concatenate 'string (list x y)))))

	(defvar +squares+ (cp +rows+ +cols+))

	(defvar +units+
	(nconc (loop for c across +cols+ collect (cp +rows+ (string c)))
	(loop for r across +rows+ collect (cp (string r) +cols+))
	(loop for rs in '("ABC" "DEF" "GHI") nconc
	(loop for cs in '("123" "456" "789") collect (cp rs cs)))))

	(defun sq-eql (sq1 sq2) (string= sq1 sq2))
	(defun sq-mem (sq sqs) (find sq sqs :test #'sq-eql))
	(defun sq-rem (sq sqs) (remove sq sqs :test #'sq-eql))
	(defun sq-remdup (sqs) (remove-duplicates sqs :test #'sq-eql))
	(defun sq-pos (sq sqs) (position sq sqs :test #'sq-eql))

	(defvar +units-map+
	(dict (sq (filter (lcurry #'sq-mem sq) +units+))
	+squares+))

	(defvar +peers-map+
	(dict (sq (sq-rem sq (sq-remdup (apply #'append (dict-get +units-map+ sq)))))
	+squares+))

	(defun units-of (sq) (dict-get +units-map+ sq "Units-Of"))
	(defun peers-of (sq) (dict-get +peers-map+ sq "Peers-Of"))

	(defun test-tables ()
	"Do a set of unit tests."
	(check-length 81 +squares+)
	(check-length 27 +units+)
	(mapc (lambda (sq) (check-length 3 (units-of sq))) +squares+)
	(mapc (lambda (sq) (check-length 20 (peers-of sq))) +squares+)
	(assert (set-equal (units-of "C2")
	'(("A2" "B2" "C2" "D2" "E2" "F2" "G2" "H2" "I2")
	("C1" "C2" "C3" "C4" "C5" "C6" "C7" "C8" "C9")
	("A1" "A2" "A3" "B1" "B2" "B3" "C1" "C2" "C3"))))
	(assert (set-equal (peers-of "C2")
	'("A2" "B2" "D2" "E2" "F2" "G2" "H2" "I2"
	"C1" "C3" "C4" "C5" "C6" "C7" "C8" "C9"
	"A1" "A3" "B1" "B3")))
	(princ "All tests pass.")
	(terpri))

	;;;===================================================================
	;;; Parser

	;; String -> Map Sq String, where length of String is either 1 or 0.
	(defun grid-values (grid)
	(let ((chars
	(loop for c across grid
	when (or (find c +digits+) (if (find c "0.") "")) collect it)))
	(check-length 81 chars)
	(dict (sq (string (elt chars (sq-pos sq +squares+))))
	+squares+)))

	(defvar +initial-values+ (dict (sq +digits+) +squares+))

	(defun moves-for-grid (grid)
	(loop for sq being the hash-keys in (grid-values grid) using (hash-value str)
	do (assert (<= (length str) 1))
	when (string/= "" str) collect (cons sq (elt str 0))))

	;; String -> Maybe Values, where type Values = Map Sq [Digit]
	(defun parse-grid (grid)
	(foldM #'assign (dict-copy +initial-values+) (moves-for-grid grid)))

	;;;===================================================================
	;;; Solver

	;; Values -> Move -> Maybe Values, where type Move = (Sq, Digit)
	(defun assign (values move)
	(destructuring-bind (sq . d) move
	(foldM #'eliminate values (k-zip sq (remove d (dict-get values sq))))))

	;; Values -> Move -> Maybe Values
	(defun eliminate (values move)
	(destructuring-bind (sq . d) move
	(let ((digits (dict-get values sq)))
	(if (not (find d digits))
	values
	(let ((digits2 (remove d digits)))
	(foldM (lcurry* #'place d)
	(case (length digits2)
	(0 nil)
	(1 (foldM #'eliminate
	(dict-set! values digits2 sq)
	(zip-k (peers-of sq) (elt digits2 0))))
	(t (dict-set! values digits2 sq)))
	(units-of sq)))))))

	;; Digit -> Values -> Unit -> Maybe Values
	(defun place (d values unit)
	(let ((sqs (filter (lambda (sq) (find d (dict-get values sq))) unit)))
	(cond ((null sqs) nil)
	((null (cdr sqs)) (assign values (cons (car sqs) d)))
	(t values))))

	;;;===================================================================
	;;; Unparser

	(defun values-string (vals)
	(let* ((w (1+ (loop for v being the hash-values in vals maximize (length v))))
	(hl (make-string (1+ (* 3 w)) :initial-element #\-))
	(brk (format nil "~a+~a+~a~%" hl hl hl)))
	(flet ((sq-str (sq &aux (d (dict-get vals sq)))
	(format nil "~v,a" w (if (string= d "") "." d))))
	(join brk
	(mapcar (lambda (xs) (format nil "~{ ~a\| ~a\| ~a~%~}" xs))
	(groups-of 9
	(loop for sqs in (groups-of 3 +squares+) collect
	(concat (mapcar #'sq-str sqs)))))))))

	(defun display (maybe-values &optional (st standard-output))
	(when maybe-values
	(format st (values-string maybe-values))
	(finish-output st)))

	;;;===================================================================
	;;; Explorer

	(defparameter use-heuristics-p nil
	"A flag to switch whether or not to use a heuristics to select next moves.")

	(defun analyze-values (values)
	"Analyze the current board status, i.e. VALUES. Return (T NIL) if a solution is found, otherwise return (NIL POSSIBLE-NEXT-MOVES). If USE-HEURISTICS-P is off, the explorer behaves essentially same with the original python code. However if the flag is on, a heuristics defined below is applied, and it tries to select next moves for pruning search space better."
	(loop with best-len = 10
	with best-ds = nil
	with best-sq = nil
	for sq being the hash-keys in values using (hash-value ds)
	for len = (length ds)
	do (assert (plusp len))
	when (or (< 1 len best-len)
	(and use-heuristics-p
	(< 1 len) (= len best-len)
	(better-by-heuristics sq best-sq len values)))
	do (setf best-len len best-sq sq best-ds ds)
	minimize len into min-len
	maximize len into max-len
	finally (return
	(if (= 1 min-len max-len)
	(values t nil)
	(progn
	(assert best-sq)
	(values nil (k-zip best-sq best-ds)))))))

	(defvar new-board-count nil
	"A counter for counting new board generation.")

	;; Maybe Values -> Maybe Values
	(defun search-values (vals)
	(labels ((rec (v rest)
	(cond ((and (null v) (null rest))
	nil)
	((null v)
	(incf new-board-count)
	(destructuring-bind ((v2 . m2) . rest2) rest
	(rec (assign (dict-copy v2) m2) rest2)))
	(t
	(multiple-value-bind (solved? moves) (analyze-values v)
	(if solved? v (rec nil (nconc (k-zip v moves) rest))))))))
	(setf new-board-count 0)
	(rec vals '())))

	(defvar print-new-board-count-p nil)

	;; String -> Maybe Values
	(defun solve (grid &optional (print print-new-board-count-p))
	"Search a solution for a given GRID."
	(prog1 (search-values (parse-grid grid))
	(when print (format t "~&Board count = ~d~%" new-board-count))))

	;;;
	;;; Heuristics for Explorer
	;;;

	(defun better-by-heuristics (sq1 sq2 len values)
	"When the lengths in values[sq1] and values[sq2] are equal, judge which SQ is better for the next SQ candidate based on a heuristics. Return T if SQ1 is better than SQ2, otherwise NIL."
	(flet ((point> (hp1 hp2)
	;; The heuristics is:
	;; 1. take SQ, one of whose PEER having the least length value LEN
	;; 2. if LEN of SQ1 and SQ2 are same, take SQ having many PEER
	;; 3. if NUM of SQ1 and SQ2 are same, take SQ having small total LEN
	(destructuring-bind ((len1 . num1) . sum1) hp1
	(destructuring-bind ((len2 . num2) . sum2) hp2
	(cond ((= len1 len2)
	(if (= num1 num2) (< sum1 sum2) (> num1 num2)))
	(t (< len1 len2)))))))
	;; note: we don't cache a survived hp for next comparison for simplicity
	(point> (heurestics-point sq1 len values)
	(heurestics-point sq2 len values))))

	(defun heurestics-point (sq len values)
	(let* ((v1 (remove-if (rcurry #'< len)
	(sort (mapcar (lambda (p) (length (dict-get values p)))
	(peers-of sq))
	#'<)))
	(v2 (run-length-encode v1))
	(v3 (apply #'+ v1)))
	(assert (and (consp v2) (consp (car v2))))
	(assert (integerp v3))
	(cons (car v2) v3)))

	(defun run-length-encode (sorted-lst)
	"Compute run-length encoding of SORTED-LST, e.g. return ((A . 4) (B . 1) (C . 2) for (A A A A B C C)."
	(flet ((pack (lst)
	(nreverse
	(reduce (lambda (acc x)
	(cond ((null acc) (list (list x)))
	((equal (caar acc) x) (cons (cons x (car acc))
	(cdr acc)))
	(t (cons (list x) acc))))
	lst
	:initial-value '()))))
	(mapcar (lambda (x) (cons (car x) (length x)))
	(pack sorted-lst))))

	;;;===================================================================
	;;; System test

	(defun solve-all (grids &optional (name "") (show-if 0.0))
	(flet ((sum (xs) (apply #'+ xs))
	(time-solve (grid)
	(let* ((start (get-internal-real-time))
	(values (solve grid))
	(end (get-internal-real-time))
	(time (/ (coerce (- end start) 'float)
	internal-time-units-per-second)))
	;; Display puzzles that take long enough
	(when (and (numberp show-if) (> time show-if))
	(display (grid-values grid))
	(format t "~&Board count = ~d~%" new-board-count)
	(display values)
	(format t "(~f seconds)~%" time))
	(list time (solved values)))))
	(multiple-value-bind (times results)
	(loop for grid in grids
	for (time result) = (time-solve grid)
	collect time into times
	collect (if result 1 0) into results
	finally (return (values times results)))
	(let ((n (length grids)))
	(when (> n 1)
	(format t
	"Solved ~d of ~d ~7a puzzles ~
	(avg ~,3f secs (~3d Hz), max ~,3f secs).~%"
	(sum results) n name
	(floor (sum times) n) (floor n (sum times))
	(apply #'max times)))))))

	(defun solved (values)
	(flet ((unit-solved (u)
	(equal +digits+
	(sort (concat (loop for sq in u collect (dict-get values sq)))
	#'char<))))
	(if (and values (every #'unit-solved +units+))
	values)))

	(defun from-file (path &aux (eof (cons nil nil)))
	(with-open-file (st path :direction :input)
	(loop for l = (read-line st nil eof) until (eq l eof) collect l)))

	(defun to-file (grids &optional (path #p"./problems/random.txt"))
	(with-open-file (st path :direction :output :if-exists :overwrite)
	(loop for gr in grids do
	(format st "~a~%" gr))))

	(defun values-grid (values)
	(flet ((fn (sq &aux (ds (dict-get values sq)))
	(if (= 1 (length ds)) (elt ds 0) #\.)))
	(map 'string #'fn +squares+)))

	(defun random-puzzle (&optional (n 17))
	(labels ((random-move (vals sq &aux (ds (dict-get vals sq)))
	(cons sq (elt ds (random (length ds)))))
	(complete? (vals)
	(let ((ds (loop for v being the hash-values in vals
	when (= 1 (length v)) collect v)))
	(and (<= n (length ds))
	(<= 8 (length (remove-duplicates ds :test #'equal))))))
	(lp (vals sqs)
	(acond ((null sqs) ; restart
	(make-one-puzzle))
	((assign (dict-copy vals) (random-move vals (car sqs)))
	(when (complete? it)
	(return-from random-puzzle (values-grid it)))
	(lp it (cdr sqs)))
	(t
	(lp vals (cdr sqs)))))
	(make-one-puzzle ()
	(lp (dict (sq +digits+) +squares+) (shuffle-list +squares+))))
	(make-one-puzzle)))

	(defun random-puzzles (number path &optional (n-assign 17))
	(if (and (probe-file path)
	(null (y-or-n-p "Create a new version of ~A?" path)))
	(from-file path)
	(loop with pool = '()
	for grid = (random-puzzle n-assign)
	for item = (cons (sxhash grid) grid)
	for count = (if (find item pool :test #'equal) 0 1)
	for total = count then (+ total count)
	do (when (= count 1) (push item pool))
	while (< total number)
	finally (return
	(aprog1 (mapcar #'cdr pool)
	(to-file it path))))))

	(defun system-test ()
	(test-tables)
	(solve-all (from-file #p"./problems/easy50.txt") "easy" 0.1)
	(solve-all (from-file #p"./problems/top95.txt") "hard" 0.1)
	(solve-all (from-file #p"./problems/hardest.txt") "hardest" 0.1)
	; (solve-all (random-puzzles 99 #p"./problems/random.txt") "random" 0.1)
	)

	;;;===================================================================
	;;; Some test data

	(defvar grid1
	"00302060090030500100180640000810290070000
	0008006708200002609500800203009005010300")

	(defvar grid2
	"4.....8.5.3..........7......2.....6.....8
	.4......1.......6.3.7.5..2.....1.4......")

	(defvar grid3
	". . 5 \| 3 . . \| . . .
	8 . . \| . . . \| . 2 .
	. 7 . \| . 1 . \| 5 . .
	------+-------+------
	4 . . \| . . 5 \| 3 . .
	. 1 . \| . 7 . \| . . 6
	. . 3 \| 2 . . \| . 8 .
	------+-------+------
	. 6 . \| 5 . . \| . . 9
	. . 4 \| . . . \| . 3 .
	. . . \| . . 9 \| 7 . .")

	(defvar hard1
	".....6....59.....82....8....45..0.....3..
	..0...6..3.54...325..6..................")

	;;;===================================================================
	;;; Some log records
	;;;
	;;; - No.1 Solving hard1 w/ and w/o heuristics in CCL64
	;;; - No.2 ditto, but in SBCL
	;;; - No.3 Executing system-test w/ and w/o heuristics in SBCL
	;;;
	;;; As for No.1 and No.2, you can see that the problem hard1 is
	;;; also hard for SBCL, as in the original python case, but not hard
	;;; for CCL64 when use-heuristics-p is NIL. (I think it makes sense
	;;; because natural scanning order for hashtable is CL-implementation
	;;; dependent.)
	;;; At the same time, setting use-heuristics-p to T speeds up hard1
	;;; case for SBCL. I expect the heuristics averaging some prominently
	;;; time-consuming cases without exception.

	#\| No.1
	CL-USER> (lisp-implementation-type)
	"Clozure Common Lisp"
	CL-USER> (lisp-implementation-version)
	"Version 1.11-r16635 (DarwinX8664)"
	CL-USER> (display (grid-values hard1))
	. . . \| . . 6 \| . . .
	. 5 9 \| . . . \| . . 8
	2 . . \| . . 8 \| . . .
	-------+-------+-------
	. 4 5 \| . . . \| . . .
	. . 3 \| . . . \| . . .
	. . 6 \| . . 3 \| . 5 4
	-------+-------+-------
	. . . \| 3 2 5 \| . . 6
	. . . \| . . . \| . . .
	. . . \| . . . \| . . .
	NIL
	CL-USER> (setf use-heuristics-p nil)
	NIL
	CL-USER> (time (display (solve hard1 t)))
	Board count = 33
	3 8 7 \| 5 4 6 \| 9 2 1
	4 5 9 \| 2 3 1 \| 6 7 8
	2 6 1 \| 9 7 8 \| 5 4 3
	-------+-------+-------
	7 4 5 \| 6 1 2 \| 3 8 9
	8 2 3 \| 4 5 9 \| 1 6 7
	9 1 6 \| 7 8 3 \| 2 5 4
	-------+-------+-------
	1 7 4 \| 3 2 5 \| 8 9 6
	6 3 2 \| 8 9 7 \| 4 1 5
	5 9 8 \| 1 6 4 \| 7 3 2
	(DISPLAY (SOLVE HARD1 T))
	took 24,051 microseconds (0.024051 seconds) to run.
	1,292 microseconds (0.001292 seconds, 5.37%) of which was spent in GC.
	During that period, and with 4 available CPU cores,
	22,115 microseconds (0.022115 seconds) were spent in user mode
	1,863 microseconds (0.001863 seconds) were spent in system mode
	991,296 bytes of memory allocated.
	96 minor page faults, 2 major page faults, 0 swaps.
	NIL
	CL-USER> (setf use-heuristics-p t)
	T
	CL-USER> (time (display (solve hard1 t)))
	Board count = 24
	8 7 4 \| 1 3 6 \| 5 2 9
	6 5 9 \| 2 7 4 \| 3 1 8
	2 3 1 \| 9 5 8 \| 4 6 7
	-------+-------+-------
	9 4 5 \| 7 6 2 \| 8 3 1
	7 8 3 \| 5 4 1 \| 6 9 2
	1 2 6 \| 8 9 3 \| 7 5 4
	-------+-------+-------
	4 1 7 \| 3 2 5 \| 9 8 6
	5 6 2 \| 4 8 9 \| 1 7 3
	3 9 8 \| 6 1 7 \| 2 4 5
	(DISPLAY (SOLVE HARD1 T))
	took 21,695 microseconds (0.021695 seconds) to run.
	During that period, and with 4 available CPU cores,
	20,478 microseconds (0.020478 seconds) were spent in user mode
	987 microseconds (0.000987 seconds) were spent in system mode
	1,098,288 bytes of memory allocated.
	NIL
	\|#

	#\| No.2
	CL-USER> (lisp-implementation-type)
	"SBCL"
	CL-USER> (lisp-implementation-version)
	"1.4.1"
	CL-USER> (display (grid-values hard1))
	. . . \| . . 6 \| . . .
	. 5 9 \| . . . \| . . 8
	2 . . \| . . 8 \| . . .
	-------+-------+-------
	. 4 5 \| . . . \| . . .
	. . 3 \| . . . \| . . .
	. . 6 \| . . 3 \| . 5 4
	-------+-------+-------
	. . . \| 3 2 5 \| . . 6
	. . . \| . . . \| . . .
	. . . \| . . . \| . . .
	NIL
	CL-USER> (setf use-heuristics-p nil)
	NIL
	CL-USER> (time (display (solve hard1 t)))
	Board count = 658725
	4 3 8 \| 7 9 6 \| 2 1 5
	6 5 9 \| 1 3 2 \| 4 7 8
	2 7 1 \| 4 5 8 \| 6 9 3
	-------+-------+-------
	8 4 5 \| 2 1 9 \| 3 6 7
	7 1 3 \| 5 6 4 \| 8 2 9
	9 2 6 \| 8 7 3 \| 1 5 4
	-------+-------+-------
	1 9 4 \| 3 2 5 \| 7 8 6
	3 6 2 \| 9 8 7 \| 5 4 1
	5 8 7 \| 6 4 1 \| 9 3 2
	Evaluation took:
	95.807 seconds of real time
	95.413642 seconds of total run time (94.477152 user, 0.936490 system)
	[ Run times consist of 1.799 seconds GC time, and 93.615 seconds non-GC time. ]
	99.59% CPU
	153,293,840,806 processor cycles
	12,912,792,592 bytes consed

	NIL
	CL-USER> (setf use-heuristics-p t)
	T
	CL-USER> (time (display (solve hard1 t)))
	Board count = 22
	8 7 4 \| 2 3 6 \| 1 9 5
	6 5 9 \| 1 7 4 \| 3 2 8
	2 3 1 \| 9 5 8 \| 4 6 7
	-------+-------+-------
	9 4 5 \| 6 1 7 \| 8 3 2
	7 8 3 \| 5 4 2 \| 6 1 9
	1 2 6 \| 8 9 3 \| 7 5 4
	-------+-------+-------
	4 1 7 \| 3 2 5 \| 9 8 6
	3 6 2 \| 7 8 9 \| 5 4 1
	5 9 8 \| 4 6 1 \| 2 7 3
	Evaluation took:
	0.014 seconds of real time
	0.013941 seconds of total run time (0.013793 user, 0.000148 system)
	100.00% CPU
	22,212,941 processor cycles
	1,143,680 bytes consed

	NIL
	\|#

	#\| No.3
	CL-USER> (lisp-implementation-type)
	"SBCL"
	CL-USER> (lisp-implementation-version)
	"1.4.1"
	CL-USER> (setf use-heuristics-p nil)
	NIL
	CL-USER> (system-test)
	All tests pass.
	Solved 50 of 50 easy puzzles (avg 0.000 secs (131 Hz), max 0.012 secs).
	Solved 95 of 95 hard puzzles (avg 0.000 secs ( 43 Hz), max 0.120 secs).
	Solved 11 of 11 hardest puzzles (avg 0.000 secs (102 Hz), max 0.013 secs).
	NIL
	CL-USER> (setf use-heuristics-p t)
	T
	CL-USER> (system-test)
	All tests pass.
	Solved 50 of 50 easy puzzles (avg 0.000 secs (134 Hz), max 0.016 secs).
	Solved 95 of 95 hard puzzles (avg 0.000 secs ( 46 Hz), max 0.107 secs).
	Solved 11 of 11 hardest puzzles (avg 0.000 secs (119 Hz), max 0.012 secs).
	NIL
	\|#
	;;;; Solving a problem specified in https://gigazine.net/news/20100822_hardest_sudoku/ (2010-08-22)

	CL-USER> (defparameter hardest-in-the-world
	"..53..... 8......2. .7..1.5.. 4....53.. .1..7...6 ..32...8. .6.5....9 ..4....3. .....97..")
	HARDEST-IN-THE-WORLD
	CL-USER> (display (grid-values hardest-in-the-world))
	. . 5 \| 3 . . \| . . .
	8 . . \| . . . \| . 2 .
	. 7 . \| . 1 . \| 5 . .
	-------+-------+-------
	4 . . \| . . 5 \| 3 . .
	. 1 . \| . 7 . \| . . 6
	. . 3 \| 2 . . \| . 8 .
	-------+-------+-------
	. 6 . \| 5 . . \| . . 9
	. . 4 \| . . . \| . 3 .
	. . . \| . . 9 \| 7 . .
	NIL
	CL-USER> (lisp-implementation-type)
	"SBCL"
	CL-USER> (lisp-implementation-version)
	"2.0.0"
	CL-USER> (setf use-heuristics-p nil)
	NIL
	CL-USER> (time (display (solve hardest-in-the-world t)))
	Board count = 21
	1 4 5 \| 3 2 7 \| 6 9 8
	8 3 9 \| 6 5 4 \| 1 2 7
	6 7 2 \| 9 1 8 \| 5 4 3
	-------+-------+-------
	4 9 6 \| 1 8 5 \| 3 7 2
	2 1 8 \| 4 7 3 \| 9 5 6
	7 5 3 \| 2 9 6 \| 4 8 1
	-------+-------+-------
	3 6 7 \| 5 4 2 \| 8 1 9
	9 8 4 \| 7 6 1 \| 2 3 5
	5 2 1 \| 8 3 9 \| 7 6 4
	Evaluation took:
	0.011 seconds of real time
	0.011738 seconds of total run time (0.011618 user, 0.000120 system)
	109.09% CPU
	23,388,297 processor cycles
	1,080,208 bytes consed

	NIL
	CL-USER> (setf use-heuristics-p t)
	T
	CL-USER> (time (display (solve hardest-in-the-world t)))
	Board count = 8
	1 4 5 \| 3 2 7 \| 6 9 8
	8 3 9 \| 6 5 4 \| 1 2 7
	6 7 2 \| 9 1 8 \| 5 4 3
	-------+-------+-------
	4 9 6 \| 1 8 5 \| 3 7 2
	2 1 8 \| 4 7 3 \| 9 5 6
	7 5 3 \| 2 9 6 \| 4 8 1
	-------+-------+-------
	3 6 7 \| 5 4 2 \| 8 1 9
	9 8 4 \| 7 6 1 \| 2 3 5
	5 2 1 \| 8 3 9 \| 7 6 4
	Evaluation took:
	0.006 seconds of real time
	0.005804 seconds of total run time (0.005793 user, 0.000011 system)
	100.00% CPU
	11,578,316 processor cycles
	752,960 bytes consed

	NIL

	;;;; Another difficult problem for human in http://qiita.com/yumura_s/items/4e759467d64f7a0cb335
	;;;; Is this the true most difficult sudoku problem by a Finnish mathematician?
	;;;; ( Unfortunately our heuristics slows down the elapsed time a bit :-\| )

	CL-USER> (defparameter hardest-in-the-world-2
	"8..........36......7..9.2...5...7.......457.....1...3...1....68..85...1..9....4..")
	HARDEST-IN-THE-WORLD-2
	CL-USER> (display (grid-values hardest-in-the-world-2))
	8 . . \| . . . \| . . .
	. . 3 \| 6 . . \| . . .
	. 7 . \| . 9 . \| 2 . .
	-------+-------+-------
	. 5 . \| . . 7 \| . . .
	. . . \| . 4 5 \| 7 . .
	. . . \| 1 . . \| . 3 .
	-------+-------+-------
	. . 1 \| . . . \| . 6 8
	. . 8 \| 5 . . \| . 1 .
	. 9 . \| . . . \| 4 . .
	NIL
	CL-USER> (time (display (solve hardest-in-the-world-2 t)))
	Board count = 172
	8 1 2 \| 7 5 3 \| 6 4 9
	9 4 3 \| 6 8 2 \| 1 7 5
	6 7 5 \| 4 9 1 \| 2 8 3
	-------+-------+-------
	1 5 4 \| 2 3 7 \| 8 9 6
	3 6 9 \| 8 4 5 \| 7 2 1
	2 8 7 \| 1 6 9 \| 5 3 4
	-------+-------+-------
	5 2 1 \| 9 7 4 \| 3 6 8
	4 3 8 \| 5 2 6 \| 9 1 7
	7 9 6 \| 3 1 8 \| 4 5 2
	Evaluation took:
	0.046 seconds of real time
	0.046235 seconds of total run time (0.038801 user, 0.007434 system)
	100.00% CPU
	92,229,646 processor cycles
	5,132,800 bytes consed

	NIL
	CL-USER> (setf use-heuristics-p t)
	T
	CL-USER> (time (display (solve hardest-in-the-world-2 t)))
	Board count = 186
	8 1 2 \| 7 5 3 \| 6 4 9
	9 4 3 \| 6 8 2 \| 1 7 5
	6 7 5 \| 4 9 1 \| 2 8 3
	-------+-------+-------
	1 5 4 \| 2 3 7 \| 8 9 6
	3 6 9 \| 8 4 5 \| 7 2 1
	2 8 7 \| 1 6 9 \| 5 3 4
	-------+-------+-------
	5 2 1 \| 9 7 4 \| 3 6 8
	4 3 8 \| 5 2 6 \| 9 1 7
	7 9 6 \| 3 1 8 \| 4 5 2
	Evaluation took:
	0.062 seconds of real time
	0.062310 seconds of total run time (0.058274 user, 0.004036 system)
	100.00% CPU
	124,314,580 processor cycles
	7,629,296 bytes consed

	NIL
	CL-USER>