Scheme:数独
Scheme:初心者の質問箱より移動。
オープニング
数独の問題を解きたいのですが、 バックトラックがわかりません。ambを使わないバックトラックを教えてくだ さい
;; Table
(define (assoc key records)
(cond ((null? records) #f)
((equal? key (caar records)) (car records))
(else (assoc key (cdr records)))))
(define (lookup key-1 key-2 table)
(let ((subtable (assoc key-1 (cdr table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(cdr record)
#f))
#f)))
(define (insert! key-1 key-2 value table)
(let ((subtable (assoc key-1 (cdr table))))
(if subtable
(let ((record (assoc key-2 (cdr subtable))))
(if record
(set-cdr! record value)
(set-cdr! subtable
(cons (cons key-2 value)
(cdr subtable)))))
(set-cdr! table
(cons (list key-1
(cons key-2 value))
(cdr table)))))
'ok)
(define (make-table)
(list '*table*))
;; Sudoku
(define block-size 3)
(define board-size (* block-size block-size))
問題はリストのquote
(define list
'(
(9 7 0 3 0 4 0 6 5)
(0 2 0 5 0 6 0 8 0)
(0 0 0 0 0 0 0 0 0)
(0 0 5 8 0 2 9 0 0)
(0 0 2 0 4 0 3 0 0)
(0 0 8 7 0 5 1 0 0)
(0 0 0 0 0 0 0 0 0)
(0 6 0 2 0 8 0 3 0)
(8 4 0 1 0 9 0 2 7)
))
;input-data
(define (input-data list table)
(define (input-line x y list table)
(cond ((pair? list)
(insert! x y (car list) table)
(input-line x (+ y 1) (cdr list) table))))
(define (input-row x list table)
(cond ((pair? list)
(input-line x 1 (car list) table)
(input-row (+ x 1) (cdr list) table))))
(input-row 1 list table))
- gemma(2007/05/28 08:06:54 PDT): こんな感じでどうでしょう。ambもconcat-mapも使っていません。time は 0m3.039s でした (Thinkpad X60)。
(use srfi-1)
(use srfi-43)
(use util.list) ;; slices
(define-constant 1-9 (iota 9 1))
(define (single? l)
(and (pair? l) (null? (cdr l))))
(define (row-list i)
(iota 9 (* (quotient i 9) 9)))
(define (col-list i)
(iota 9 (modulo i 9) 9))
(define (block-list i)
(let1 a (+ (* (quotient i 27) 27) (* (quotient (modulo i 9) 3) 3))
(map (lambda (c)
(+ (* (quotient c 3) 9) (modulo c 3) a))
(iota 9))))
(define (sudoku-print mat)
(for-each print (slices (vector->list mat) 9))
(newline))
(define (solve mat)
(define (logical-solve! mat)
(define modified? #f)
(vector-for-each (lambda (i x)
(unless (single? x)
(let1 v (lset-difference =
1-9
(concatenate (filter single? (map (lambda (c)
(vector-ref mat c))
(append (row-list i) (col-list i) (block-list i))))))
(unless (equal? x v)
(vector-set! mat i v)
(set! modified? #t)))))
mat)
(if modified?
(logical-solve! mat)
mat))
(define (trials-list mat)
(let1 coord (vector-skip single? mat)
(map (lambda (x)
(let1 mat-copy (vector-copy mat)
(vector-set! mat-copy coord (list x))
mat-copy))
(vector-ref mat coord))))
(logical-solve! mat)
(cond
((vector-any null? mat) #f)
((vector-every single? mat) (sudoku-print mat) (exit))
(else (for-each solve (trials-list mat)))))
(define (main args)
(let1 mat (vector 8 0 0 0 0 0 0 0 3
0 6 0 0 9 0 0 0 0
0 7 0 0 0 5 0 0 6
2 0 0 0 0 0 0 9 0
0 4 0 0 6 0 0 7 0
0 1 0 2 0 0 0 0 8
5 0 0 1 0 0 0 2 0
0 0 0 0 5 0 0 4 0
7 0 0 0 0 0 0 0 9)
(vector-map! (lambda (i x)
(if (= x 0)
1-9
(list x)))
mat)
(solve mat)))
- gemma(2007/05/28 08:06:54 PDT):高速化するために、ひとつの枡目を表すのに9ビットの値を使うようにしたり(123456789 -> 111111111, 138 -> 010000101)、メモ化を導入したりしたものです。time は 0m0.823s になりました。
(use srfi-1)
(use srfi-43)
(use util.list) ;; slices
(define-constant 1-9 #b111111111)
(define rcb-vector (make-vector 81))
(define (single? l)
(cond
((= l 1) 1) ((= l 2) 2) ((= l 4) 3) ((= l 8) 4) ((= l 16) 5) ((= l 32) 6)
((= l 64) 7) ((= l 128) 8) ((= l 256) 9) (else #f)))
(define (row-list i)
(iota 9 (* (quotient i 9) 9)))
(define (col-list i)
(iota 9 (modulo i 9) 9))
(define (block-list i)
(let1 a (+ (* (quotient i 27) 27) (* (quotient (modulo i 9) 3) 3))
(map (lambda (c)
(+ (* (quotient c 3) 9) (modulo c 3) a))
(iota 9))))
(define (sudoku-print mat)
(for-each (lambda (li)
(for-each (lambda (c)
(display (single? c)))
li)
(newline))
(slices (vector->list mat) 9))
(newline))
(define (solve mat)
(define (logical-solve! mat)
(define modified? #f)
(vector-for-each (lambda (i x)
(unless (single? x)
(let1 v (logxor 1-9 (fold logior 0 (filter! single? (map (lambda (c)
(vector-ref mat c))
(force (vector-ref rcb-vector i))))))
(unless (equal? x v)
(vector-set! mat i v)
(set! modified? #t)))))
mat)
(if modified?
(logical-solve! mat)
mat))
(define (trials-list mat)
(let1 coord (vector-skip single? mat)
(filter-map (lambda (x)
(and (logbit? x (vector-ref mat coord))
(let1 mat-copy (vector-copy mat)
(vector-set! mat-copy coord (expt 2 x))
mat-copy)))
(iota 9))))
(logical-solve! mat)
(cond
((vector-any zero? mat) #f)
((vector-every single? mat) (sudoku-print mat) (exit))
(else (for-each solve (trials-list mat)))))
(define (main args)
(let1 mat (vector 8 0 0 0 0 0 0 0 3
0 6 0 0 9 0 0 0 0
0 7 0 0 0 5 0 0 6
2 0 0 0 0 0 0 9 0
0 4 0 0 6 0 0 7 0
0 1 0 2 0 0 0 0 8
5 0 0 1 0 0 0 2 0
0 0 0 0 5 0 0 4 0
7 0 0 0 0 0 0 0 9)
(vector-map! (lambda (i x)
(if (= x 0)
1-9
(expt 2 (- x 1))))
mat)
(vector-map! (lambda (i x)
(delay (append (row-list i) (col-list i) (block-list i))))
rcb-vector)
(solve mat)))