続続数独パズル
少し改良。エンバグしていませんように。
;; 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)))