数独ソルバ

バックトラック使うと数独一瞬で解けるよと知り合いが言っていたので作ってみた。
letで配列がコピーされると思っていてはまった。されないんですね。

virtualbox上のubuntu*1のsbclで

(time (solve sample-board1))
=>
Evaluation took:
  0.562 seconds of real time
  0.560035 seconds of total run time (0.556035 user, 0.004000 system)
  [ Run times consist of 0.024 seconds GC time, and 0.537 seconds non-GC time. ]
  99.64% CPU
  1,722,599,745 processor cycles
  96,661,592 bytes consed

(time (solve (empty-board)))
=>
Evaluation took:
  0.076 seconds of real time
  0.076005 seconds of total run time (0.064004 user, 0.012001 system)
  [ Run times consist of 0.028 seconds GC time, and 0.049 seconds non-GC time. ]
  100.00% CPU
  232,640,772 processor cycles
  7,985,088 bytes consed

とかだった。空の盤を"解か"せる*2と1桁速いのがなんだか面白い。数独でぐぐって最初に出てきたページの問題を解かせても1桁早かったし。手で解く難易度とはまた別の見え方をしてるんだろうな。"手で解く難易度"については http://winnie.kuis.kyoto-u.ac.jp/SUDOKU/solver.ja.html がそれっぽそうなことをしている。

主にデバッグ目的で(3^2)x(3^2)だけじゃなくて(L^2)x(L^2)のものを扱えるようにしてみたがwikipedia見ると長方形とかぐねぐねしたのとかいろいろあるのね。

しかしバックトラックの強力なこととloopマクロの便利なこと。

(progn
  (defconstant L 3 "width and height of a small cell, i.e. the entire board is (L^2)x(L^2). 3 for ordinary sudoku.")
  (defconstant N (* L L) "the maximum number which appears in sudoku board"))

;(defun board-valid-p (b) (not (board-invalid-p b)))
(defun board-invalid-p (b)
  (or
   (loop for i from 0 below N thereis (row-invalid-p b i))
   (loop for j from 0 below N thereis (column-invalid-p b j))
   (loop for p from 0 below L thereis 
		(loop for q from 0 below L thereis (cell-invalid-p b p q)))))

(defun row-invalid-p (b i)
  (nodupp (delete 0 (loop for j from 0 below N collect (aref b i j)))))
(defun column-invalid-p (b j)
  (nodupp (delete 0 (loop for i from 0 below N collect (aref b i j)))))
(defun cell-invalid-p (b p q)
  (nodupp (delete 0 
		  (loop for x from 0 below L append
		       (loop for y from 0 below L collect (aref b (+ x (* L p)) (+ y (* L q))))))))

(defun nodupp (list) "returns t if there is no duplication in list" (find t (maplist #'(lambda (ls) (let ((r)) (dolist (v (cdr ls)) (when (= v (car ls)) (setq r t))) r)) list)))

(defun empty-board ()
  (make-array (list N N) :element-type 'fixnum :initial-element 0))


;; (defun random-filled-board ()
;;   (let ((b (make-array (list N N) :element-type 'fixnum)))
;;     (loop for i from 0 below N do
;; 	 (loop for j from 0 below N do (setf (aref b i j) (1+ (random 9)))))
;;     b))

(defun solve (b)
  (solve-from b 0 0))

(defun solve-from (b i j)
  "back track"
  (cond ((board-invalid-p b) nil)
	((null (find 0 (loop for i from 0 below N append (loop for j from 0 below N collect (aref b i j))))) b)
	((= (aref b i j) 0)
	 (loop for v from 1 to N when
	      (let ((b_ (board-changed b i j v)))
		(solve-from b_ (if (= j (1- N)) (1+ i) i) (mod (1+ j) N)))
	    return it))
	(t (solve-from b (if (= j (1- N)) (1+ i) i) (mod (1+ j) N)))))

(defun solve-multi (b)
  "return all solutions to the board"
  (let ((solutions))
    (labels ((solve-from-multi (b i j)
	       (cond ((board-invalid-p b) nil)
		     ((null (find 0 (loop for i from 0 below N append (loop for j from 0 below N collect (aref b i j)))))
		      (push b solutions)
		      nil)
		     ((= (aref b i j) 0)
		      (loop for v from 1 to N do
			   (let ((b_ (board-changed b i j v)))
			     (solve-from-multi b_ (if (= j (1- N)) (1+ i) i) (mod (1+ j) N)))))
		     (t (solve-from-multi b (if (= j (1- N)) (1+ i) i) (mod (1+ j) N))))))
      (solve-from-multi b 0 0)
      solutions)))


(defun copy-array (array)
  "http://lemonodor.com/archives/000100.html"
  (let ((dims (array-dimensions array)))
    (adjust-array
     (make-array dims :displaced-to array :element-type (array-element-type array))
     dims)))
	
(defun board-changed (b i j v)
  "returns b with only the value at (i,j) is changed"
  (let ((b_ (copy-array b)))
    (setf (aref b_  i j) v)
    b_))

(setq sample-board1			;http://ja.wikipedia.org/wiki/%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB:Sudoku-by-L2G-20050714.svg
      #2A((5 3 0 0 7 0 0 0 0)
	  (6 0 0 1 9 5 0 0 0)
	  (0 9 8 0 0 0 0 6 0)
	  (8 0 0 0 6 0 0 0 3)
	  (4 0 0 8 0 3 0 0 1)
	  (7 0 0 0 2 0 0 0 6)
	  (0 6 0 0 0 0 2 8 0)
	  (0 0 0 4 1 9 0 0 5)
	  (0 0 0 0 8 0 0 7 9)))
(setq sample-board2 ;いくつか数字を抜いて解を1意でなくしたもの
      #2A((5 3 0 0 7 0 0 0 0)
	  (6 0 0 1 9 5 0 0 0)
	  (0 9 8 0 0 0 0 6 0)
	  (8 0 0 0 6 0 0 0 3)
	  (4 0 0 8 0 3 0 0 1)
	  (7 0 0 0 2 0 0 0 0)
	  (0 6 0 0 0 0 2 8 0)
	  (0 0 0 4 1 9 0 0 5)
	  (0 0 0 0 8 0 0 0 0)))
; (solve sample-board1)
; (length (solve-multi sample-board2))  ;解の個数

*1:デスクトップのcore i5 2400のcpu中2コアを割り振ってる

*2:もちろんゴリ押ししていって一番最初にvalidになる解を発見するまで。