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