vallog: Scheme で数独を解く

明日で 25 回目となる 9LISP（もはや言語は Lisp に限らない、という状態ですが（笑））の宿題が、「数独を解くプログラム」なのでやってみました。Scheme （Gauche）で書きました。

まず数独を良く知らなかったのでそこから。

数独 - Wikipedia

簡単な問題を解いてみるとこんな具合。

(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))
; real   0.109
; user   0.094
; sys    0.000
;; #t

(time (equal? (backtrack-solver test-data-2)
              test-data-2-ans))
; real   0.172
; user   0.125
; sys    0.015
;; #t

とても遅いですね。。

バックトラックで解く方の実装がだいぶ残念な感じですが、一応「数学のエキスパートが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))
; real  15.438
; user  15.375
; sys    0.047
;; #t

amb とか cps を使ってできそうな気がしたので、四苦八苦しながらやってみましたが、結局できずこの有様・・・。明日の 9LISP が終わってからまた改めて考えてみます。

ということで、とりあえずさらしておきます。

valvallow's sudoku at master - GitHub

全景はこんな感じ。

(use srfi-1) ; drop, split-at
(use srfi-9) ; define-record-type
(use util.list) ; slices
(use liv.matrix) ; matrix-*, *-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))))

;; matrix x or y -> region position
(define (region-pos mn)
  (quotient mn region-size))

;; mmatrix x and y -> region index
(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)))

;;
;; naked single solve
;;

(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)))))

;;
;; backtrack solver
;;

(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)))))