数独

Gaucheで数独解くﾌﾟﾛｸﾞﾗﾑを作ってみました｡
Gigazineに前のっていた世界で一番解くのが難しい問題とか言うのも解けたので､多分大丈夫だと思います｡
数学のエキスパートが3ヶ月かけて作成した「世界一難しい数独」 - GIGAZINE

005300000
800000020
070010500
400005300
010070006
003200080
060500009
004000030
000009700

という感じで未確定ﾏｽを0にして入力すると､

>gosh sudoku.scm problem.txt

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

という感じで答えが出ます｡速度はそこそこ｡問題の入力は面倒ですね｡
解き方は普通です｡途中変な工夫しようとしたら無駄にはまったので素直なやり方にしました｡

1.すべての未確定のﾏｽに(1 2 3 4 5 6 7 8 9)というﾘｽﾄを用意する｡
2. 確定しているﾏｽと同じﾌﾞﾛｯｸ､同じ列､同じ行のﾏｽのﾘｽﾄから確定ﾏｽの数字を削除する｡
3.すべての確定しているﾏｽについて2.を行う｡
4.未確定ﾏｽが残っている場合は､深さ優先探索を行う｡
5.同じﾌﾞﾛｯｸ､または同じ列､または同じ行に同じ数字の確定ﾏｽができたらﾊﾞｯｸﾄﾗｯｸ｡
6.未確定ﾏｽがなくなったら探索終了｡

という流れです｡resolveが5と6の実装､clean-board､cleanが1と2と3の実装です｡あとはほとんどﾃﾞｰﾀｱｸｾｽ用の関数です｡CLOSを使ってboardをｵﾌﾞｼﾞｪｸﾄにすればよかったかなｰと思いつつ面倒なのでそのままです｡
cleanが汚い感じなので残念｡あと

 (let ((value (proc1 A)))
   (if (pred) (proc2 value) (proc3 value)))

というのをすっきりと各方法が思いつかなかった。

しかしいつも良い名前がつけられなくて困ります｡

(use srfi-1)
(use gauche.sequence)
(define *width* 9)
(define *blocks* 3)

(define (resolved? lst)
  (null? (cdr lst)))

(define (idx->ij idx)
  (values (quotient idx *width*) (modulo idx *width*)))

(define (memoize func)
  (let* ((cache (make-hash-table 'equal?))
	 (getCache (cut hash-table-get cache <> #f))
	 (setCache! (lambda (key value) (hash-table-put! cache key value) value)))
    (lambda args
      (cond [(getCache args) => values]
	    [else (setCache! args (apply func args))]))))

;;board struct
(define (read-board port)
  (let loop ((board ()))
    (let* ((line (read-line port)))
      (if (eof-object? line)
	  board
	  (loop (append board (map digit->integer (string->list line))))))))

(define (init-board board);board = (<not-resolved list> . <board>)
  (if (= (length board) (* *width* *width*))
      board
      (error "this file is not valid sudoku problem"))
  (cons (iota (* *width* *width*))
	(list->vector (map (lambda (i) (if (= i 0) (iota *width* 1) (list i))) board))))

(define (get-val board idx)
  (vector-ref (cdr board) idx))

(define (set-val! board idx val)
  (vector-set! (cdr board) idx val))

(define (copy-board board)
  (cons (list-copy (car board)) (vector-copy (cdr board ))))

(define (resolve! board idx)
  (set! (car board) (remove (cut = <> idx) (car board))))

(define (map-with-index-board! proc idx-list board)
  (for-each (lambda (idx)
	      (receive (i j) (idx->ij idx)
		(set-val! board idx (proc idx (get-val board idx)))))
	    idx-list) board)

(define (each-with-index-board proc idx-list board)
  (map-with-index-board! (lambda (idx val) (proc idx val) val) idx-list board))

(define (not-resoleved-idx-lst board)
  (car board))
  
(define (num-not-resolved board)
  (fold (lambda (val prev)
	  (if (resolved? val) prev (+ prev 1)))
	0 (cdr board)))

(define (make-candidates board)
  (let ((idx (caar board)))
    (map (lambda (val) (let ((new-board (copy-board board))) (set-val! new-board idx (list val)) new-board)) (get-val board idx))))

(define (print-board board)
  (for-each-with-index
   (lambda (idx val)
     (receive (i j) (idx->ij idx)
       (when (= j 0)
	 (display (if (= 0 (modulo i 3)) "\n\n" "\n")))
       (cond [(null? val) (display "!")]
	     [(resolved? val) (display (car val))]
	     [else (display "-")])
       (if (= 2 (modulo j 3))
	   (display "  ")
	   (display " "))))
   (cdr board))
  (display "\n"))

;;make index list related to "idx"
(define (get-region-idx-list idx) 
  (receive (i j) (idx->ij idx)
    (let ((region-i (quotient i *blocks*)) (region-j (quotient j *blocks*)))
      (remove
       (cut = <> idx)
       (filter (lambda (idx)
		 (if (and (= region-i (quotient idx (* *blocks* *width*)))
			  (= region-j (quotient (modulo idx *width*) *blocks*)))
		     #t #f))
	       (iota (* *width* *width*)))))))
  
(define (get-row-idx-list idx)
  (receive (i j) (idx->ij idx)
    (remove (cut = <> idx)
	    (map (cut + <> (* i *width*)) (iota *width*)))))

(define (get-column-idx-list idx)
  (receive (i j) (idx->ij idx)
    (remove (cut = <> idx)
	    (map (lambda (x) (+ j (* x *width*))) (iota *width*)))))

(define get-related-idx-list
  (memoize (lambda (idx) (lset-union equal? (get-region-idx-list idx) (get-row-idx-list idx) (get-column-idx-list idx)))))

;;
(define (delete lst val) ;; remove (resolved? lst)
  (remove (cut = <> (car val)) lst))

(define (block proc)
  (call/cc proc))

(define (clean! board)
  (block (lambda (break)
	   (each-with-index-board
	    (lambda (idx val)
	      (resolve! board idx)
	      (map-with-index-board!
	       (lambda (idx2 lst)
		 (let ((newlst (delete lst val)))
		   (if (null? newlst) (break #f) newlst)))
	       (get-related-idx-list idx) board))
	    (filter (lambda (idx) (resolved? (get-val board idx))) (not-resoleved-idx-lst board)) board)
	   (num-not-resolved board))))

(define (clean-board! board)
  (let loop ((prev-resolved +inf.0))
    (let ((resolved (clean! board)))
      (cond [(not resolved) #f]; backtrack
	    [(or (= resolved prev-resolved) (= resolved 0)) resolved]
	    [else (loop resolved)]))))

(define (resolve init-board)
  (let loop ((stack (list init-board)))
    (when (null? stack) (print "I cannot solve this problem!") (exit))
    (case (clean-board! (car stack))
	[(#f) (loop (cdr stack))]
	[(0) (car stack)]
	[else (loop (append (make-candidates (car stack)) (cdr stack)))])))

(define (main args)
  (if (null? (cdr args))
      (print "file not found")
      (call-with-input-file (cadr args)
	(lambda (iport)
	  (print-board (resolve (init-board (read-board iport))))))))