数独パズル続き

続き。問題は解けているようだ。
データ構造としては、Python の辞書(dict)をCLのハッシュテーブルとしている。またオリジナルのコードで文字列で保持しているsquareが取りうる値は、とりあえずリストとしている。

まだ残念ながら Python の リスト内包表記のエレガントさにかなわない。理由はわたしの腕不足は置いておいて、いくつかある。Python の辞書は、Common Lisp のハッシュテーブルよりもずっと言語に密着している。Python の「+」が賢い。組み込み以外のマクロをまだ使っていない。

ハッシュテーブルを使わずに、より Common Lisp が得意な、リスト構造を使えば、もう少しエレガントに書けるかもしれない。

;; 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)))

;; (test test-basic)

(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 を返す。"
  (let ((values (make-hash-table)))
    ;; 最初はどのマスも全ての数字でありうる。
    (loop for s in squares do (setf (gethash s values) digits))
    (loop for s being the hash-keys in (grid-values grid)
       using (hash-value d)
       if (and (member d digits) (not (assign values s d)))
       do (return nil)
       finally (return values))))

(defun assign (values s d) 
  "values[s]からd以外のすべての値を取り除き、伝播する。valuesを返す。
ただし矛盾が見つかった場合はnilを返す。"
  (loop for d2 in (remove d (gethash s values))
     unless (eliminate values s d2)
     do (return nil)
     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 
        (let ((d2 (car (gethash s values))))
          (loop 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)
        do
          (case (length dplaces)
            (0
             (return-from eliminate nil)) ;; 矛盾 値を置ける場所がない
            (1 ;; 一箇所しかないので、そこに置く。
             (unless (assign values (car dplaces) d)
               (return-from eliminate nil)))))
     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)
  (unless values
    (return-from search-sudoku nil))

  (when (every (lambda (s) (= (length (gethash s values)) 1)) squares)
    (warn "solved: ")
    (return-from search-sudoku values))

  (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)
     for new-value = (search-sudoku (assign (copy-values values) s0 d))
     if new-value
     do (return-from search-sudoku new-value)))

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