数独プログラム

　「 あらゆる数独パズルを解く」はPeter Norvigなのに、Pythonで書かれている。
　じゃあというわけでelispで書いてみた。

(2) ある値に対し、ユニットの中で置ける場所が1つしかないなら、その値をそこに置く。

　は、うまく動かなかったのでコメントアウトしているけど。
　それでも「 あらゆる数独パズルを解く」のページの問題はいちおう解けたからだいじょうぶだと思うけど。
　まぁ、よいか。

( defun  test ()
  ( progn (sudoku-init)
(sudoku-set  "
 . . 5 |3 . . |. . . 
 8 . . |. . . |. 2 . 
 . 7 . |. 1 . |5 . . 
 ------+------+------
 4 . . |. . 5 |3 . . 
 . 1 . |. 7 . |. . 6 
 . . 3 |2 . . |. 8 . 
 ------+------+------
 . 6 . |5 . . |. . 9 
 . . 4 |. . . |. 3 . 
 . . . |. . 9 |7 . . 
 ")
       (sudoku-solve)
       (sudoku-print)))

(benchmark 1 '(test))
| 1 4 5 | 3 2 7 | 6 9 8 |
| 8 3 9 | 6 5 4 | 1 2 7 |
| 6 7 2 | 9 1 8 | 5 4 3 |
|-------+-------+-------|
| 4 9 6 | 1 8 5 | 3 7 2 |
| 2 1 8 | 4 7 3 | 9 5 6 |
| 7 5 3 | 2 9 6 | 4 8 1 |
|-------+-------+-------|
| 3 6 7 | 5 4 2 | 8 1 9 |
| 9 8 4 | 7 6 1 | 2 3 5 |
| 5 2 1 | 8 3 9 | 7 6 4 |
 "Elapsed time: 0.179490s (0.093774s in 1 GCs)"

　ベンチマークもそこそこ。

	;; -*- coding: utf-8; lexical-binding: t -*-
	;;
	;; 数独(sudoku.el)
	;;
	(require 'cl)
	(require 'org)
	(require 'dash)
	(defun sudoku-combination-of-list (list1 list2)
	"list1の要素とlist2の要素を組み合わせた結果を出力する。"
	(-table-flat 'concat list1 list2))
	(defun sudoku-table-convert (string)
	"文字列をtableに変換する。"
	(with-temp-buffer
	(let ((w (replace-regexp-in-string "^\n" "" string)))
	(insert w)
	(org-table-convert-region (point-min)(point-max))
	(goto-char (point-min))
	(next-line 2)
	(org-ctrl-c-minus)
	(next-line 4)
	(org-ctrl-c-minus)
	(buffer-substring-no-properties (point-min)(point-max)))))
	(let* ((tate '("1" "2" "3" "4" "5" "6" "7" "8" "9"))
	(yoko '("A" "B" "C" "D" "E" "F" "G" "H" "I"))
	(tate-group (-partition 3 tate))
	(yoko-group (-partition 3 yoko))
	(keys (sudoku-combination-of-list tate yoko))
	(hash (make-hash-table :size 81 :test 'equal)))
	(defun sudoku-hash ()
	hash)
	(defun sudoku-keys() keys)
	(defun sudoku-init ()
	"初期化処理"
	(loop for x in keys ; 初期設定
	do (puthash x "123456789" hash)))
	(sudoku-init) ; 最初の初期化
	(defun sudoku-units (key)
	"KEYはマス目の場所をあらわす。pearになるリストを返す。"
	(let* ((tate-key (substring key 0 1))
	(yoko-key (substring key 1 2))
	(tate (loop for x in tate-group
	when (cl-find tate-key x :test #'string=)
	collect x))
	(yoko (loop for x in yoko-group
	when (cl-find yoko-key x :test #'string=)
	collect x)))
	(sudoku-combination-of-list (car tate)(car yoko))))
	(defun sudoku-tate (key)
	(let ((tate-key (substring key 0 1)))
	(sudoku-combination-of-list (list tate-key) yoko)))
	(defun sudoku-yoko (key)
	(let ((yoko-key (substring key 1 2)))
	(sudoku-combination-of-list tate (list yoko-key))))
	(defun sudoku-cross (key)
	"十字のpearになるリストを返す。"
	(-concat (sudoku-yoko key)(sudoku-tate key)))
	(defun sudoku-peares (key)
	"KEYのpearになるリストを返す。"
	(let* ((peares (-concat (sudoku-units key)
	(sudoku-cross key)))
	(peares (remove-if (lambda(x)(equal x key)) peares)))
	(delete-dups peares)))
	(cl-defun sudoku-print (&optional (hash hash))
	"hashテーブルの中身をバッファに出力する。"
	(let* ((w (loop for x in keys
	collect (gethash x hash)))
	(w (-partition 9 w))
	(w (loop for x in w
	collect
	(mapconcat 'concat (loop for y in (-partition 3 x)
	collect
	(mapconcat 'concat y " ")) "\t"))))
	(insert (sudoku-table-convert (loop for x in w
	concat (concat x "\n"))))))
	(defun sudoku-value-overwrite (key value hash)
	"hashのkeyの値をvalueにする。"
	(let ((other-values (replace-regexp-in-string value "" (gethash key hash))))
	(not (loop for x in (cl-concatenate 'list other-values)
	unless (sudoku-value-minus key (char-to-string x) hash)
	return t))))
	(defun sudoku-value-minus (key value hash)
	"hashのkeyの値からvalueを削除する。"
	(let* ((w (gethash key hash))
	(rtn (cond ((not (search value w)) w)
	((search value w)(let ((w2 (replace-regexp-in-string value "" w)))
	(setf (gethash key hash) w2)
	(case (length w2)
	(0 nil)
	(1 (not (loop for x in (sudoku-peares key)
	unless (sudoku-value-minus x w2 hash)
	return t)))
	(t t)))))))
	rtn
	;; (when rtn
	;; (not (loop for unit in (list (sudoku-tate key)(sudoku-yoko key)(sudoku-units key))
	;; unless (let ((w (loop for x in unit
	;; when (search value (gethash x hash))
	;; collect x)))
	;; (case (length w)
	;; (0 (return nil))
	;; (1 (sudoku-value-overwrite (car w) value hash))
	;; (t t)))
	;; return t)))
	))
	(defun sudoku-set (string)
	(loop for x in keys
	for y in (sudoku-conv string)
	when (string= (replace-regexp-in-string "\[1-9\]" "" y) "")
	collect (sudoku-value-overwrite x y hash)))
	(defun sudoku-conv (string)
	(let* ((w (replace-regexp-in-string "\[^0-9.\]" " " string))
	(w (mapconcat 'char-to-string (cl-concatenate 'string w) " ")))
	(split-string w)))
	(defun sudoku-min (hash)
	(loop for x in keys
	unless (= (length (gethash x hash)) 1)
	minimize (length (gethash x hash))))
	(defun sudoku-complete-p (hash)
	(let ((w (loop for x in keys
	when (= (length (gethash x hash)) 1)
	count x)))
	(when (= 81 w)
	t)))
	(defun sudoku-solve-run (hash)
	(if (sudoku-complete-p hash)
	hash
	(let* ((min (sudoku-min hash))
	(key (loop for x in keys
	when (= (length (gethash x hash)) min)
	do (return x))))
	(loop for y in (cl-concatenate 'list (gethash key hash))
	do (let ((w (copy-hash-table hash))
	(x (char-to-string y)))
	(when (sudoku-value-overwrite key x w)
	(when-let (rtn (sudoku-solve-run w))
	(return rtn))))))))
	(defun sudoku-solve()
	(when-let (w (sudoku-solve-run (copy-hash-table hash)))
	(setq hash w))))
	(defun test ()
	(progn (sudoku-init)
	(sudoku-set "
	. . 5 |3 . . |. . .
	8 . . |. . . |. 2 .
	. 7 . |. 1 . |5 . .
	------+------+------
	4 . . |. . 5 |3 . .
	. 1 . |. 7 . |. . 6
	. . 3 |2 . . |. 8 .
	------+------+------
	. 6 . |5 . . |. . 9
	. . 4 |. . . |. 3 .
	. . . |. . 9 |7 . .
	")
	;; (sudoku-set "
	;; 8 5 . |. . 2 |4 . .
	;; 7 2 . |. . . |. . 9
	;; . . 4 |. . . |. . .
	;; ------+------+------
	;; . . . |1 . 7 |. . 2
	;; 3 . 5 |. . . |9 . .
	;; . 4 . |. . . |. . .
	;; ------+------+------
	;; . . . |. 8 . |. 7 .
	;; . 1 7 |. . . |. . .
	;; . . . |. 3 6 |. 4 .
	;; ")
	(sudoku-solve)
	(sudoku-print)))

view raw sudoku.el hosted with ❤ by GitHub