数独ソルバ by 非決定性マクロ

On Lisp --- 非決定性をみて憧れみたいなものがあったので非決定性マクロを使って数独ソルバを書きなおしてみようという試み。

とりあえず空欄の部分に対して全部choose-bindしてしまおうと思ったのだけど、何が困るってbindする変数の個数が決まらないんですよね。
なので指定したシンボルにリストを束縛してnthで参照したりとかできるようにしよう、とかやったら3日ぐらい潰れてしまった。on lispのchoose-bind(先のurl)を拡張した感覚です。common lisp。

(choose-bind-list vars 5 '(1 2 3 4 5 6 7)
  (if (and (= (apply #'+ vars) 13)
	   (= (apply #'* vars) 60))
      vars
      (fail))) 
 ;=> (1 2 2 3 5)

とかやることで数字5個の組で、足し合わせれば13になって掛けあわせれば60になるようなものを返す、というもの。

ソース全体:

(defparameter *paths* nil)
(defconstant failsym '@)

(defmacro choose-setf (var choices &body body)
  (let ((g (gensym)))
    `(cb #'(lambda (,g) (setf ,var ,g) ,@body) ,choices)))

(defun cb (fn choices)
  (if choices
      (progn
	(if (cdr choices)
	    (push #'(lambda () (cb fn (cdr choices)))
		  *paths*))
	(funcall fn (car choices)))
      (fail)))

(defun fail ()
  (if *paths*
      (funcall (pop *paths*))
      failsym))

(defmacro choose-bind-list (var length choices &body body)
  (let ((len (gensym "len")) (stack (gensym "stack")) (i (gensym "i")) (result (gensym "result")) (b (gensym "b")) (ls (gensym "ls")))
    `(eval (funcall (lambda (,len ,b)
		      (let ((,stack)
			    (,result))
			(loop for ,i from 0 below ,len do (push `(choose-setf (nth ,(eval ,i) ,',var) ',,choices) ,stack))
			(setf ,result (list 'funcall ,b ',var))
			(loop while ,stack do (setf ,result (append (pop ,stack) (list ,result))))
			(setf ,result (append `(let ((,',var (make-list ,(eval ,len))))) (list ,result)))
			,result))
		    ,length (lambda (,ls) (let ((,var ,ls)) ,@body))))))

(defmacro choose-bind-vector (var length choices &body body)
  (let ((len (gensym "len")) (stack (gensym "stack")) (i (gensym "i")) (result (gensym "result")) (b (gensym "b")) (ls (gensym "ls")))
    `(eval (funcall (lambda (,len ,b)
		      (let ((,stack)
			    (,result))
			(loop for ,i from 0 below ,len do (push `(choose-setf (aref ,',var,(eval ,i)) ',,choices) ,stack))
			(setf ,result (list 'funcall ,b ',var))
			(loop while ,stack do (setf ,result (append (pop ,stack) (list ,result))))
			(setf ,result (append `(let ((,',var (make-array ',(eval ,len))))) (list ,result)))
			,result))
		    ,length (lambda (,var) ,@body)))))

;; 数独ソルバ

(progn
  (defconstant L 3 "width and height of a small cell, 3 for ordinary sudoku")
  (defconstant N (* L L) "numbers from 1 to N appears in sudoku board"))

(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)
  (dupp (delete 0 (loop for j from 0 below N collect (aref b i j)))))
(defun column-invalid-p (b j)
  (dupp (delete 0 (loop for i from 0 below N collect (aref b i j)))))
(defun cell-invalid-p (b p q)
  (dupp (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 dupp (list) "returns t if there is 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 iota (p) (loop for i from 1 to p collect i))

(defmacro aif (cond then else)
  `(let ((it ,cond))
      (if it ,then ,else)))

(defun solve (b)
  (setf *paths* nil)
  (let ((emptypoints (loop for i from 0 below N append (loop for j from 0 below N if (zerop (aref b i j)) collect (list i j)))))
    (choose-bind-vector vals (length emptypoints) (iota N)
      (let ((b_ (board-changed* b emptypoints vals)))
	(if (board-invalid-p b_) (fail) b_)))))

(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 points vals)
  (let ((b_ (copy-array b)))
    (loop 
       for point being the elements of points
       for value being the elements of vals
       do (setf (aref b_  (car point) (cadr point)) value))
    b_))

;; (print (time (solve 
;;   #2A((5 3 4 6 7 8 9 1 2)
;;       (6 7 2 1 9 5 3 4 8)
;;       (1 9 8 3 4 0 0 6 7)
;;       (8 5 9 7 6 1 4 2 3)
;;       (4 2 6 0 5 3 7 9 1)
;;       (7 1 3 9 2 4 8 5 6)
;;       (9 6 1 5 3 7 2 8 4)
;;       (2 8 7 4 0 9 0 3 5)
;;       (3 4 5 2 8 6 1 7 0)))))
;; 
;; (terpri)

listだと効率悪そうかと思ってvector版も定義してあります。なんでchoose-bind-(vector|list)の定義がこんな面倒なことになっているかというと安直にやるとbodyとかlengthとかが評価されるときに環境から切り離されてしまって困るからです。

問題はこのsolveの書き方では恐ろしく遅いということで、前回のバックトラックだったら埋めて行く途中で条件に引っかかって処理が戻るようなところまで全種類の可能性を馬鹿正直に試すようになっているので末尾にコメントアウトされてある穴が6つしかない問題でもうちの環境で3秒とかかかりますし、穴が増えると指数的に時間が増すので普通に人間が取り組むような問題は実際上解けません。

前回のバックトラックみたいにいっこ入れて都度大丈夫か確認してみたいなことをやると前回のとほぼ同じ速度が出ましたが見た目が前回とほぼ同じになるので略。

evalとか多分滅茶苦茶効率悪いので気持ち悪いとは思う。