数独パズル

Peter Norvig の「あらゆる数独パズルを解く」 を実装したくなった。途中だが記録として取っておく。まだ面白いところ（探索とか制約伝播とか）には入っていない。

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

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

Link