続続数独パズル

少し改良。エンバグしていませんように。

;; sudoku solver 
;; see peter norvig's article(sudoku.htm)

(in-package :common-lisp-user)
(ql:quickload :com.gigamonkeys.test-framework)

(defpackage :sudoku
  (:use :cl :com.gigamonkeys.test))

(in-package :sudoku)

(defvar digits '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(defvar rows '(#\A #\B #\C #\D #\E #\F #\G #\H #\I))
(defvar cols digits)

(defun squaresym (x y)
  "シンボルxとシンボルyから、シンボルxyを作る。"
  (intern (format nil "~a~a" x y)))

(defun cross (xs ys)
  "Xsの要素とYsの要素の外積。"
  (loop for x in xs append (loop for y in ys collect (squaresym x y))))

(defvar squares (cross rows digits) "squares")

(defvar unit-list
  (append
   (loop for c in cols collect (cross rows (list c)))
   (loop for r in rows collect (cross (list r) cols))
   (loop for (a1 a2 a3) on rows by #'cdddr
      append (loop for (n1 n2 n3) on cols by #'cdddr
                collect (cross (list a1 a2 a3) (list n1 n2 n3))))))

(defvar units 
  (loop with ht = (make-hash-table)
     for s in squares
     do (setf (gethash s ht)
              (loop for u in unit-list
                 if (member s u) collect u))
     finally (return ht))
  "units")

(defvar peers
  (loop with ht = (make-hash-table)
     for s in squares
     do (setf (gethash s ht)
              (loop with peer = nil
                 ;; fixme not elegant..
                 for ss in (apply #'append (gethash s units))
                 unless (eql s ss)
                 do (pushnew ss peer)
                 finally (return peer)))
     finally (return ht))
  "peers")

(deftest test-basic ()
  (check
    (= 81 (length squares))
    (= 27 (length unit-list))
    ;; 全ての square は 3つの unit に属する
    (every #'(lambda (s) (= 3 (length (gethash s units)))) squares)
    ;; 全ての square は 20 の peer を持つ
    (every #'(lambda (s) (= 20 (length (gethash s peers)))) squares)))

(defvar grid-ex-0
  "003020600900305001001806400008102900700000008006708200002609500800203009005010300")

(defvar grid-ex-1
  "
4 . . |. . . |8 . 5 
. 3 . |. . . |. . . 
. . . |7 . . |. . . 
------+------+------
. 2 . |. . . |. 6 . 
. . . |. 8 . |4 . . 
. . . |. 1 . |. . . 
------+------+------
. . . |6 . 3 |. 7 . 
5 . . |2 . . |. . . 
1 . 4 |. . . |. . . ")

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

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

(defun grid-values (grid)
  "テキスト形式 grid をハッシュテーブルに変換する。空のマスは0か.とする。"
  (loop with ht = (make-hash-table)
     for c across grid
     if (or (member c digits) (member c '(#\. #\0)))
     collect c into chars
     finally
       (assert (= 81 (length chars)) (chars) "Invalid grid format")
       (loop for s in squares for cc in chars
          do (setf (gethash s ht) cc))
       (return ht)))

(defun parse-grid (grid)
  "テキスト形式 grid を可能な値のハッシュテーブルに変換する。
square => digits
ただし矛盾が見つかった場合は nil を返す。"
  (loop with values = (make-hash-table)
     initially
     ;; 最初はどのマスも全ての数字でありうる。
       (loop for s in squares do (setf (gethash s values) digits))
     for s being the hash-keys in (grid-values grid)
     using (hash-value d)
     never (and (member d digits) (not (assign values s d)))
     finally (return values)))

(defun assign (values s d) 
  "values[s]からd以外のすべての値を取り除き、伝播する。valuesを返す。
ただし矛盾が見つかった場合はnilを返す。"
  (loop for d2 in (remove d (gethash s values))
     always (eliminate values s d2)
     finally (return values)))

(defun eliminate (values s d)
  "values[s]からdを取り除く。値か場所が一つになったら伝播する。"
  (assert (member d digits))
  (cond
    ((not (member d (gethash s values))) ;; 既にdは取りのぞかれている
     values)
    (t
     (setf (gethash s values) (remove d (gethash s values)))
     ;; 1) 1つの値 d2 にまで絞られたら、peer から d2 を取りのぞく。
     ;; もし矛盾が生じたら nil を返す。
     (case (length (gethash s values))
       (0
        (return-from eliminate nil)) ;; 矛盾 最後の値が取りのぞかれた
       (1 
        (loop
           with d2 = (car (gethash s values))
           for s2 in (gethash s peers)
           unless (eliminate values s2 d2)
           do (return-from eliminate nil))))
     ;; 2) ユニットu で値 d を置きうる場所が一箇所だけになったなら、d をその場所に入れる。
     (loop for u in (gethash s units)
        for dplaces = (loop for s in u if (member d (gethash s values)) collect s)
        always (not (null dplaces)) ;; 矛盾 値を置ける場所がない場合 nil
        if (= 1 (length dplaces)) ;; 一箇所しかないので、そこに置く。
        do (unless (assign values (car dplaces) d) ;; assign に失敗したら nil
             (return nil))
        finally (return values)))))

(defun copy-values (old)
  "Create copy of hash-table."
  (loop with new = (make-hash-table)
     for k being the hash-keys in old
     do (setf (gethash k new) (copy-seq (gethash k old)))
     finally (return new)))

(defun search-sudoku (values)
  (cond
    ((null values) nil)
    ((every (lambda (s) (= (length (gethash s values)) 1)) squares) values)
    (t
     (loop with min = (loop for s in squares
                         if (> (length (gethash s values)) 1)
                         minimizing (length (gethash s values)))
        with s0 = (find-if #'(lambda (s) (= (length (gethash s values)) min)) squares)
        for d in (gethash s0 values)
        thereis (search-sudoku (assign (copy-values values) s0 d))))))

(defun solve (grid)
  "数独パズルをパーズし解く。"
  (search-sudoku (parse-grid grid)))
  
(defun display (values)
  "values を2次元のテキスト形式で表示する。"
  (loop with width = (1+ (loop for s in squares
                            maximizing (length (gethash s values))))
     with line = (format nil "~{~a~^+~}"
                         (make-list 3 :initial-element
                                    (make-string (* width 3) :initial-element #\-)))
     for r in rows do
       (loop for c in cols
          do (format t "~v:@<~{~a~^~}~>" width (gethash (squaresym r c) values))
          if (member c '(#\3 #\6))
          do (format t "|")
          if (member c '(#\9))
          do (format t "~%"))
     if (member r '(#\C #\F))
     do (format t "~a~%" line)))