明日で 25 回目となる
9LISP（もはや言語は Lisp に限らない、という状態ですが（笑））の宿題が、「数独を解くプログラム」なのでやってみました。Scheme （Gauche）で書きました。
まず数独を良く知らなかったのでそこから。
簡単な問題を解いてみるとこんな具合。
(define test-data-1
'((7 8 0 5 2 0 0 0 6)
(9 0 0 0 0 3 0 7 5)
(0 0 5 0 0 6 0 4 0)
(0 0 4 0 6 1 3 0 2)
(1 0 0 9 0 0 0 0 7)
(8 0 2 0 7 0 6 0 0)
(0 5 0 2 0 0 8 0 0)
(6 3 0 4 0 0 0 0 1)
(2 0 0 0 3 7 0 5 9)))
(define test-data-1-ans
'((7 8 1 5 2 4 9 3 6)
(9 4 6 1 8 3 2 7 5)
(3 2 5 7 9 6 1 4 8)
(5 7 4 8 6 1 3 9 2)
(1 6 3 9 4 2 5 8 7)
(8 9 2 3 7 5 6 1 4)
(4 5 7 2 1 9 8 6 3)
(6 3 9 4 5 8 7 2 1)
(2 1 8 6 3 7 4 5 9)))
(define test-data-2
'((0 0 7 0 4 0 0 0 0)
(0 3 0 9 1 0 6 2 0)
(0 0 0 7 0 0 3 8 4)
(2 4 9 0 7 1 5 3 6)
(1 5 0 0 0 0 0 7 8)
(0 0 8 5 0 0 0 9 1)
(0 9 2 0 8 4 7 5 3)
(0 8 0 6 0 2 1 4 9)
(5 1 4 3 0 0 0 6 2)))
(define test-data-2-ans
'((8 6 7 2 4 3 9 1 5)
(4 3 5 9 1 8 6 2 7)
(9 2 1 7 6 5 3 8 4)
(2 4 9 8 7 1 5 3 6)
(1 5 6 4 3 9 2 7 8)
(3 7 8 5 2 6 4 9 1)
(6 9 2 1 8 4 7 5 3)
(7 8 3 6 5 2 1 4 9)
(5 1 4 3 9 7 8 6 2)))
(time (equal? (backtrack-solver test-data-1)
test-data-1-ans))
(time (equal? (backtrack-solver test-data-2)
test-data-2-ans))
とても遅いですね。。
バックトラックで解く方の実装がだいぶ残念な感じですが、一応「
数学のエキスパートが3ヶ月かけて作成した「世界一難しい数独」 - GIGAZINE」も解けました。遅いですが。
(define most-difficult-data
'((0 0 5 3 0 0 0 0 0)
(8 0 0 0 0 0 0 2 0)
(0 7 0 0 1 0 5 0 0)
(4 0 0 0 0 5 3 0 0)
(0 1 0 0 7 0 0 0 6)
(0 0 3 2 0 0 0 8 0)
(0 6 0 5 0 0 0 0 9)
(0 0 4 0 0 0 0 3 0)
(0 0 0 0 0 9 7 0 0)))
(define most-difficult-data-ans
'((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)))
(time (equal? (backtrack-solver most-difficult-data)
most-difficult-data-ans))
amb とか cps を使ってできそうな気がしたので、四苦八苦しながらやってみましたが、結局できずこの有様・・・。明日の
9LISP が終わってからまた改めて考えてみます。
ということで、とりあえずさらしておきます。
全景はこんな感じ。
(use srfi-1) (use srfi-9) (use util.list) (use liv.matrix)
(define-constant region-size 3)
(define-constant fullset-numbers (iota (* region-size region-size) 1))
(define (single? ls)
(and (pair? ls)
(null? (cdr ls))))
(define (region-pos mn)
(quotient mn region-size))
(define (region-index mx my)
(+ (region-pos mx)
(* region-size
(region-pos my))))
(define (region-ref region n)
(list-ref region n))
(define (slice-matrix-rows matrix size)
(map (lambda (row)
(slices row size)) matrix))
(define (matrix->regions matrix size)
(let1 sliced (slice-matrix-rows matrix size)
(let rec ((m sliced)(acc '()))
(if (null? m)
(apply append (reverse acc))
(receive (took dropped)(split-at m size)
(rec dropped (cons (apply map append took) acc)))))))
(define (candidates matrix x y . keywords)
(let-keywords* keywords ((eq? =)
(empty? zero?)
(ignore '()))
(let1 f (pa$ filter (complement empty?))
(let* ((row-candidates (f (matrix-row-ref matrix y)))
(col-candidates (f (matrix-col-ref matrix x)))
(region-candidates (f (region-ref (matrix->regions matrix region-size)
(region-index x y)))))
(lset-difference eq? fullset-numbers row-candidates
col-candidates region-candidates
ignore)))))
(define (has-empty? matrix :optional (empty? zero?))
(let/cc hop
(fold (lambda (row acc)
(if-let1 it (any empty? row)
(hop it)
acc)) #f matrix)))
(define (fix-naked-singles matrix . keywords)
(let-keywords* keywords ((empty? zero?)
(car car))
(let1 exist? #f
(values (map-matrix-with-index
(lambda (e x y)
(if (empty? e)
(let1 can (candidates matrix x y)
(if (single? can)
(begin
(unless exist?
(set! exist? (not exist?)))
(car can))
e))
e)) matrix)
exist?))))
(define (fix-naked-singles-solver matrix
:optional (more identity))
(let rec ((m matrix))
(receive (cand exist?)(fix-naked-singles m)
(cond (exist? (rec cand))
((has-empty? cand)(more cand))
(else cand)))))
(define-record-type point
(make-point x y) point?
(x point-x)
(y point-y))
(define (backtrack-solver matrix)
(let/cc hop
(let ((mstack '())(cstack '())(pstack '())(count 0))
(let backtrack ((m (matrix-copy matrix))(bt-cand '())
(bt-point (make-point -1 -1)))
(for-each-matrix-with-index
(lambda (e x y)
(when (zero? e)
(let1 cand (if (and (= x (point-x bt-point))
(= y (point-y bt-point)))
bt-cand
(candidates m x y))
(cond ((null? cand)
(inc! count)
(backtrack (pop! mstack)
(pop! cstack)
(pop! pstack)))
((single? cand)
(matrix-set! m x y (car cand)))
(else
(push! mstack (matrix-copy m))
(push! cstack (cdr cand))
(push! pstack (make-point x y))
(matrix-set! m x y (car cand))))))) m)
(hop m count)))))
追記
@aharisu さんが scheme で書いたものは、私が書いたものと比べて 3 ～ 7 倍高速でした！
追記2
@kikuchan98 さんによる実装。短くて美しくて速い！流石っす。
amb 使ってあります。しかもこれが scheme で書いた初めてのコードらしいです・・・。
