パズル「数独 (ナンバープレース) 」の続きです。今回は基本的な「確定サーチ」を実装して、プログラムの高速化に挑戦してみましょう。
最初に、今回のプログラムで使用する高階関数を定義しましょう。まずは畳み込みを行う関数 bit-fold を作ります。
リスト : 畳み込み (ビット版)
(define (bit-fold func init n)
(let loop ((n n) (a init))
(if (<= n 0)
a
(let ((m (logand (- n) n)))
(loop (logxor n m) (func m a))))))
bit-fold は引数 n のオンビットを順番に取り出し、その値と累積変数 a を引数の関数 func に渡します。単純な畳み込みの処理なので難しいところはないと思います。簡単な実行例を示しましょう。
gosh> (bit-fold (lambda (x a) (cons x a)) '() 255) (128 64 32 16 8 4 2 1) gosh> (bit-fold (lambda (x a) (cons x a)) '() 1024) (1024) gosh> (bit-fold (lambda (x a) (cons x a)) '() 1234) (1024 128 64 16 2)
次はベクタ用の畳み込み関数 vector-fold です。vector-fold はライブラリ SRFI-43 に用意されていますが、私たちでも簡単にプログラムすることができます。
リスト : ベクタ用畳み込み関数
(define (vector-fold f a v)
(define (iter i a)
(if (= (vector-length v) i)
a
(iter (+ i 1) (f i a (vector-ref v i)))))
(iter 0 a))
vector-fold はベクタ用の fold で、ベクタの要素だけではなく添字も引数の関数 f に渡します。第 1 引数が添字、第 2 引数が累積変数、第 3 引数がベクタの要素です。簡単な例を示しましょう。
gosh> (vector-fold (lambda (x a y) (cons (cons x y) a)) '() #(a b c)) ((2 . c) (1 . b) (0 . a))
また、Gauche のオブジェクト指向システムには、ベクタだけではなくリストや文字列など sequence 型のデータに対して同じ動作を行うメソッド fold-with-index が用意されています。ライブラリ gauche.sequence をロードすると利用することができます。簡単な例を示します。
gosh> (use gauche.sequence) #<undef> gosh> (fold-with-index (lambda (x y a) (cons (cons x y) a)) '() #(a b c)) ((2 . c) (1 . b) (0 . a)) gosh> (fold-with-index (lambda (x y a) (cons (cons x y) a)) '() '(a b c)) ((2 . c) (1 . b) (0 . a))
それでは、確定サーチを行うプログラムを作りましょう。関数 init-flag でヒント数字を解析したら、空き場所に対して確定サーチを行います。確定サーチで注意する点は、確定できなかったマスでも、ほかのマスで数字が決定することで、確定できる場合があることです。したがって、一度だけ調べるのではなく、数字が確定したマスがある限り、何度でも調べなければいけません。プログラムは次のようになります。
リスト : 確定サーチ + バックトラック
; 確定できる数字を探す
(define (search-number)
(when (positive? (+ (search-cell)
(search-sub *xflag* get-x-cell)
(search-sub *yflag* get-y-cell)
(search-sub *gflag* get-g-cell)))
(search-number)))
; 解けたか？
(define (finish?)
(not (vector-index zero? *board*)))
; 解法
(define (solver2 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(search-number)
(cond ((finish?)
(print "kakutei")
(print-bit-board))
(else
(print "backtrack")
(dfs 0))))
確定サーチは関数 search-number で行います。search-cell は置くことができる数字がひとつしかないマス (セル) を探します。search-sub は、縦横枠の中で置くことができるマスがひとつしかない数字を探します。第 1 引数にフラグ、第 2 引数にマスの位置を求める関数を渡します。返り値は確定した数字の個数です。確定した数字がひとつでもあれば確定サーチを繰り返します。
確定サーチが終了したら、関数 finish? で問題が解けたかチェックします。finish? は *bodard* に空き場所 (0) があれば #f を返します。ベクタの探索は SRFI-43 に用意されている関数 vector-index を使うと簡単です。
vector-index pred vec1 vec2 ...
vector-index はベクタの要素を先頭から順番に取り出して述語 pred に渡し、pred が真となる要素の位置を返します。
簡単な例を示しましょう。
gosh> (vector-index odd? #(2 4 6 1 8 10)) 3 gosh> (vector-index odd? #(2 4 6 8 10 1)) 5 gosh> (vector-index odd? #(2 4 6 8 10 12)) #f
述語 pred を満たす要素が見つからない場合、vector-index は #f を返します。
空き場所が見つからなければ、確定サーチだけで解くことができました。print-bit-board で盤面を出力します。簡単な問題であれば、確定サーチだけで解くことができるでしょう。また、難しい問題でも、確定サーチだけで解ける場合もあります。確定サーチで解けない場合は、関数 dfs を呼び出してバックトラックで解を求めます。
次は search-cell を作ります。
リスト : 置ける数字がひとつしかないマスを探す
(define (search-cell)
(vector-fold
(lambda (k a n)
(if (positive? n)
a
(let ((m (get-number-bit k)))
(cond ((zero? m)
(error "data error"))
((= (logcount m) 1)
(put-number! m k)
(inv-flag! m k)
(+ a 1))
(else a)))))
0
*board*))
search-cell は簡単です。vector-fold で *board* の要素を順番に取り出してチェックします。ラムダ式の引数 k が位置、a が確定した数字の個数 (累積変数)、n が数字です。n が 0 でなければ空き場所でないので a を返します。そうでなければ、get-number-bit で置くことができる数字を求め、オンビットの個数が 1 であれば、k の位置は数字 n で確定することができます。put-number! で盤面に n を書き込んで inv-flag! でフラグを反転します。最後に a を +1 して返します。
次は縦、横、枠の確定サーチを行う関数 search-sub を作ります。
リスト : 縦、横、枠の確定サーチ
(define (search-sub flag getpos)
(vector-fold
(lambda (i a fg)
(bit-fold
(lambda (n b)
(let ((ks (search-place n (getpos i))))
(cond ((single? ks)
(put-number! n (car ks))
(inv-flag! n (car ks))
(+ b 1))
(else b))))
a
fg))
0
flag))
関数 search-sub の引数 flag はフラグを格納しているベクタ、getpos はマスの位置を求める関数です。たとえば、縦方向をチェックする場合、search-sub に *xflag* と get-cell-x を渡します。そして、vector-fold で 9 つの方向を順番に調べていきます。
次に、bit-fold で置くことができる数字を順番に取り出します。ラムダ式の引数 n が数字を表します。それから、関数 search-place で n を置くことができる場所を求めます。返り値はリストです。要素がひとつしかない場合、その場所は数字 n で確定することができます。put-number! で (car ks) の位置に n を書き込み、inv-flag! でフラグを反転します。
次は関数 search-place を作ります。
リスト : 数字を置ける場所を探す
(define (search-place n ls)
(fold (lambda (k a)
(if (and (space? k)
(positive? (logand (get-number-bit k) n)))
(cons k a)
a))
'()
ls))
search-place は fold を使うと簡単です。ラムダ式の引数 k がマスの位置を表します。マス k が空き場所の場合、get-number-bit で k に置ける数字を求め、n との論理積が 0 でなければ、k に n を置くことができます。この場合は累積変数 a に k を追加します。そうでなければ、a をそのまま返します。
あとのプログラムは簡単なので説明は割愛します。詳細は プログラムリスト１ をお読みください。
それでは、実際に数独を解いてみましょう。Puzzle Generater Japan にある Java版標準問題集 より問題 8-a, 8-b, 9-a, 9-b, 10-a, 10-b を解いてみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (1) : (2) : (3) ------+------+------+------+------------ 8-a : 20 : 1.04 : 0.34 : 0.023 8-b : 20 : 2.78 : 0.85 : 0.013 (確) 9-a : 20 : 3.44 : 1.04 : 0.020 9-b : 21 : 1.31 : 0.41 : 0.013 (確) 10-a : 22 : 0.29 : 0.12 : 0.013 10-b : 22 : 0.61 : 0.20 : 0.011 (確) 実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche ver 0.9.2
(3) が確定サーチを行った結果です。(確) は確定サーチだけで解けたことを表します。結果を見ればおわかりのように、確定サーチの効果はとても高く、どの問題も高速に解くことできました。確定サーチを行うことにより、空き場所の数を減らすことができるので、バックトラックで解を求める場合でも高速に解くことができます。
ただし、どのような問題でも高速に解けるわけではありません。Puzzle Generater Japan にある Java版超難問集 の超難問 849 と 1122 を解いてみたところ、実行時間は次のようになりました。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (1) : (2) : (3) ------+------+------+------+------ 849 : 24 : 5.44 : 1.54 : 0.79 1122 : 24 : 2.94 : 0.84 : 0.36 実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche ver 0.9.2
確定サーチの効果は確かにあるのですが、基本的な確定サーチだけでは高速化に限界があるようです。確定サーチを強化する、またはバックトラックで解を探索するとき、試行の順番を工夫するともう少し速くなるかもしれません。興味のある方はいろいろ試してみてください。
参考 URL によると、候補となる数字が最小のマスから試行していくと、実行時間が速くなるそうです。どれくらい速くなるのか、実際に試してみました。次のリストを見てください。
リスト : 候補となる数字の少ないマスから調べる
(define (search-min-cell)
(vector-fold
(lambda (k a n)
(if (positive? n)
a
(let ((c (logcount (get-number-bit k))))
(if (< c (cdr a))
(cons k c)
a))))
'(#f . 10)
*board*))
関数 search-min-cell は、候補の数字が最小となるマスを返します。vector-fold で *board* の要素を順番に取り出して、マス k が空き場所であれば、get-number-bit で候補の数字を求め、logcount で数字の個数を数えます。その個数 c が累積変数の値 (cdr a) より小さい場合は、位置 k と個数をセルに格納して返します。そうでなければ a をそのまま返します。
search-min-cell は数字の個数が 0 のマスも返すことに注意してください。この場合、解はないのですぐにバックトラックしたほうが効率的です。今までの探索ではマスを順番に調べていくので、数字の候補がなくなったマスをすぐに検出することができませんでした。つまり、無駄な探索が行われていたわけです。
たとえば、最初に調べるマスに数字の候補が 2 つある場合、最初の数字を選んで探索を行い、候補の数字が 0 となるマスが見つかれば、その時点で探索する局面数を 1 / 2 に減らすことができます。試行する順番だけではなく、数字の候補が 0 となるマスを素早く見つけることも高速化の重要なポイントになります。
次は search-min-cell を用いて深さ優先探索を行う関数 dfs1 を作ります。
リスト : 深さ優先探索
(define (dfs1)
(let ((k (car (search-min-cell))))
(if (not k)
(print-bit-board)
(bit-for-each
(lambda (n)
(put-number! n k)
(inv-flag! n k)
(dfs1)
(put-number! 0 k)
(inv-flag! n k))
(get-number-bit k)))))
dfs1 は簡単です。最初に search-min-cell で数字が最小の候補数のマスを求めます。k が #f の場合、空き場所が見つからない、つまり、解を求めることができました。print-bit-board で盤面を表示します。そうでなければ、get-number-bit で候補の数字を求め、bit-for-each で数字を順番に試していきます。数字の候補が無い場合はすぐにバックトラックすることに注意してください。
最後に dfs1 を呼び出して数独を解く関数 solver3 と solver4 を作ります。
リスト : 数独の解法
; 単純なバックトラック
(define (solver3 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(dfs1))
; 確定サーチ＋バックトラック
(define (solver4 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(search-number)
(cond ((finish?)
(print "kakutei")
(print-bit-board))
(else
(print "backtrack")
(dfs1))))
solver3 は単純な深さ優先探索、solver4 は確定サーチ＋深さ優先探索です。
それでは実行してみましょう。
表 : 実行結果 (単位 : 秒) 問題 : Hint : (2) : (2a) : (3) : (3a) ------+------+------+-------+-------+------ 8-a : 20 : 0.34 : 0.27 : 0.023 : 0.025 8-b : 20 : 0.85 : 0.061 : 0.013 : 0.013 9-a : 20 : 1.04 : 0.25 : 0.020 : 0.021 9-b : 21 : 0.41 : 0.12 : 0.013 : 0.013 10-a : 22 : 0.12 : 0.027 : 0.013 : 0.016 10-b : 22 : 0.20 : 0.013 : 0.011 : 0.011 849 : 24 : 1.54 : 0.12 : 0.79 : 0.098 1122 : 24 : 0.84 : 0.096 : 0.36 : 0.081 (2a) solver3 の実行結果 (3a) solver4 の実行結果 実行環境 : Windows 7, Core i7-2670QM 2.20GHz, Gauche ver 0.9.2
(2) と (2a) では、どの問題も (2a) のほうが速くなりました。改良の効果は十分に出ていると思います。(3) と (3a) では、(3a) のほうがわずかに遅くなる場合もありました。確定サーチである程度マスが埋まると、数字の候補数が少ない状態になるので、search-min-cell を用いなくても高速に解けるのでしょう。問題 849, 1122 は確定サーチの効果が少ないので、(3a) のほうが高速になりました。
;
; nplace.scm : 数独の解法
; (確定サーチ＋バックトラック)
;
; Copyright (C) 2013 Makoto Hiroi
;
(use srfi-1)
(use srfi-43)
; 定数
(define SIZE 9)
(define SIZE2 (* SIZE SIZE))
; 盤面
(define *board* #f)
; 縦、横、枠の位置を格納する
(define *xyg-tbl* #f)
(define *x-tbl* #f)
(define *y-tbl* #f)
(define *g-tbl* #f)
; 盤面のアクセス関数
(define (get-number k) (vector-ref *board* k))
(define (put-number! n k) (vector-set! *board* k n))
; 縦横枠のマスを求める
(define (get-cell k) (vector-ref *xyg-tbl* k))
; 縦方向のマスを求める
(define (get-x-cell k) (vector-ref *x-tbl* k))
; 横方向のマスを求める
(define (get-y-cell k) (vector-ref *y-tbl* k))
; 枠内のマスを求める
(define (get-g-cell k) (vector-ref *g-tbl* k))
; 添字 -> 座標
(define (get-x k) (modulo k SIZE))
(define (get-y k) (quotient k SIZE))
(define (get-g k)
(+ (quotient (get-x k) 3) (* (quotient (get-y k) 3) 3)))
; 空き場所か？
(define (space? k) (zero? (get-number k)))
; テーブルの初期化
(define (init-tbl)
(set! *x-tbl*
(list->vector (map (lambda (k) (iota SIZE k SIZE))
(iota SIZE 0))))
(set! *y-tbl*
(list->vector (map (lambda (k) (iota SIZE (* k SIZE)))
(iota SIZE 0))))
(set! *g-tbl*
(list->vector
(map (lambda (k)
(let ((start (vector-ref #(0 3 6 27 30 33 54 57 60) k)))
(map (lambda (x) (+ start x))
'(0 1 2 9 10 11 18 19 20))))
(iota SIZE 0))))
(set! *xyg-tbl*
(list->vector (map (lambda (p)
(sort (lset-union eqv?
(get-x-cell (get-x p))
(get-y-cell (get-y p))
(get-g-cell (get-g p)))))
(iota SIZE2 0)))))
; 安全確認
(define (safe? n k)
(every (lambda (x) (not (= (get-number x) n))) (get-cell k)))
; 盤面の表示
(define (print-board)
(dotimes (k SIZE2)
(display (get-number k))
(display " ")
(if (= (modulo k SIZE) (- SIZE 1)) (newline))))
; 解法
(define (solver qs)
(define (iter k)
(cond ((>= k SIZE2)
(print-board))
((space? k)
(do ((n 1 (+ n 1)))
((> n SIZE))
(when (safe? n k)
(put-number! n k)
(iter (+ k 1))
(put-number! 0 k))))
(else (iter (+ k 1)))))
;
(set! *board* (list->vector qs))
(iter 0))
;
; フラグ
;
(define *xflag* #f)
(define *yflag* #f)
(define *gflag* #f)
; ビット用高階関数
(define (bit-for-each func n)
(let loop ((n n))
(if (positive? n)
(let ((m (logand (- n) n)))
(func m)
(loop (logxor n m))))))
; フラグの反転
(define (inv-flag! n k)
(define (inv-flag-sub vec m)
(vector-set! vec m (logxor (vector-ref vec m) n)))
(inv-flag-sub *xflag* (get-x k))
(inv-flag-sub *yflag* (get-y k))
(inv-flag-sub *gflag* (get-g k)))
; フラグの初期化
(define (init-flag)
(set! *xflag* (make-vector SIZE #x3fe))
(set! *yflag* (make-vector SIZE #x3fe))
(set! *gflag* (make-vector SIZE #x3fe))
(dotimes (k SIZE2)
(let ((n (get-number k)))
(if (positive? n) (inv-flag! n k)))))
; 置くことができる数字を求める
(define (get-number-bit k)
(logand (vector-ref *xflag* (get-x k))
(vector-ref *yflag* (get-y k))
(vector-ref *gflag* (get-g k))))
; 数字をビットに変換
(define (make-bit-board qs)
(list->vector (map (lambda (n) (if (zero? n) n (ash 1 n))) qs)))
; 盤面を表示する
(define (print-bit-board)
(dotimes (k SIZE2)
(display (logcount (- (get-number k) 1)))
(display " ")
(if (= (modulo k SIZE) (- SIZE 1)) (newline))))
; 深さ優先探索
(define (dfs k)
(cond ((>= k SIZE2)
(print-bit-board))
((space? k)
(bit-for-each
(lambda (n)
(put-number! n k)
(inv-flag! n k)
(dfs (+ k 1))
(put-number! 0 k)
(inv-flag! n k))
(get-number-bit k)))
(else (dfs (+ k 1)))))
(define (solver1 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(dfs 0))
;;;
;;; 確定サーチ
;;;
; 畳み込み
(define (bit-fold func init n)
(let loop ((n n) (a init))
(if (<= n 0)
a
(let ((m (logand (- n) n)))
(loop (logxor n m) (func m a))))))
; 要素が一つのリストか？
(define (single? ls)
(and (pair? ls) (null? (cdr ls))))
; 置くことができる数字が一つしかないマスを探す
(define (search-cell)
(vector-fold
(lambda (k a n)
(if (positive? n)
a
(let ((m (get-number-bit k)))
(cond ((zero? m)
(error "data error"))
((= (logcount m) 1)
(put-number! m k)
(inv-flag! m k)
(+ a 1))
(else a)))))
0
*board*))
; 数字 n を置くことができるマスを探す
(define (search-place n ls)
(fold (lambda (k a)
(if (and (space? k)
(positive? (logand (get-number-bit k) n)))
(cons k a)
a))
'()
ls))
; 縦、横、枠で置くことができる場所が一つしかない数字を探す
(define (search-sub flag getpos)
(vector-fold
(lambda (i a fg)
(bit-fold
(lambda (n b)
(let ((ks (search-place n (getpos i))))
(cond ((single? ks)
(put-number! n (car ks))
(inv-flag! n (car ks))
(+ b 1))
(else b))))
a
fg))
0
flag))
; 確定できる数字を探す
(define (search-number)
(when (positive? (+ (search-cell)
(search-sub *xflag* get-x-cell)
(search-sub *yflag* get-y-cell)
(search-sub *gflag* get-g-cell)))
(search-number)))
; 解けたか？
(define (finish?)
(not (vector-index zero? *board*)))
; 解法
(define (solver2 qs)
(set! *board* (make-bit-board qs))
(init-flag)
(search-number)
(cond ((finish?)
(print "kakutei")
(print-bit-board))
(else
(print "backtrack")
(dfs 0))))
; 表の初期化
; 最初に１回だけ実行する
(init-tbl)
「ラテン方陣」は数独の枠の条件を無くした方陣です。ラテン方陣の定義を 参考文献 1 より引用します。
『ラテン方陣を一般的にいうなら、n 行 n 列の正方形の枡に n 種類の記号を n 個ずつ配列して、各行各列に記号の重複のないものを n 次のラテン方陣というのです。』
このラテン方陣をパズルに応用したものが数独というわけです。
簡単な例を示しましょう。3 次のラテン方陣は次に示す 12 通りになります。
0 1 2 0 1 2 0 2 1 0 2 1 1 0 2 1 0 2
1 2 0 2 0 1 1 0 2 2 1 0 0 2 1 2 1 0
2 0 1 1 2 0 2 1 0 1 0 2 2 1 0 0 2 1
標準形
1 2 0 1 2 0 2 0 1 2 0 1 2 1 0 2 1 0
0 1 2 2 0 1 0 1 2 1 2 0 0 2 1 1 0 2
2 0 1 0 1 2 1 2 0 0 1 2 1 0 2 0 2 1
図 : 3 次のラテン方陣
この中で、最初の行と列の要素を昇順に並べたものを「標準形」といいます。3 次のラテン方陣の場合、標準形は 1 種類しかありません。ラテン方陣は任意の行を交換する、または任意の列を交換してもラテン方陣になります。3 次のラテン方陣の場合、標準形から行または列を交換することで、残りの 11 種類のラテン方陣を生成することができます。
参考文献 [1] によると、n 次のラテン方陣の総数は標準形の個数を In とすると、次の式で表すことができます。
n! * (n - 1)! * In
ちなみに、In の値は n が増えると急激に増加します。参考文献 [1] より引用します。
I3 = 1 I4 = 4 I5 = 56 I6 = 9408 I7 = 16942080 I8 = 535281401856 I9 = 377597570964258816
n 次の標準形ラテン方陣を生成するプログラムは、数独の解法プログラムを改造することで簡単に作成することができます。プログラムの説明は割愛するので、興味のある方は プログラムリスト２ をお読みください。
なお、高次の標準形ラテン方陣の総数は、簡単に求めることができない非常にハードな問題です。今回のプログラムで I7 の総数を求めようとしたのですが、筆者の貧弱な実行環境ではいつまでたっても終わらないので途中であきらめました。
プログラムの中でラテン方陣を生成する関数が latina です。
latina func size
latina は高階関数です。size 次の標準形ラテン方陣を生成し、それを引数の関数 func に渡します。簡単な実行例を示しましょう。
gosh> (latina (lambda (x) (print-board x 3)) 3) 0 1 2 1 2 0 2 0 1 #<undef> gosh> (latina (lambda (x) (print-board x 4)) 4) 0 1 2 3 1 0 3 2 2 3 0 1 3 2 1 0 0 1 2 3 1 0 3 2 2 3 1 0 3 2 0 1 0 1 2 3 1 2 3 0 2 3 0 1 3 0 1 2 0 1 2 3 1 3 0 2 2 0 3 1 3 2 1 0 #<undef>
5 次、6 次のラテン方陣の個数を求めると次のようになります。
gosh> (let ((c 0)) (latina (lambda (x) (inc! c)) 5) c) 56 gosh> (let ((c 0)) (latina (lambda (x) (inc! c)) 6) c) 9408
ちなみに、5 次、6 次、7 次で最初に出力されるラテン方陣は次のようになります。
gosh> (call/cc (lambda (break) (latina (lambda (x) (print-board x 5) (break #t)) 5))) 0 1 2 3 4 1 0 3 4 2 2 3 4 0 1 3 4 1 2 0 4 2 0 1 3 #t gosh> (call/cc (lambda (break) (latina (lambda (x) (print-board x 6) (break #t)) 6))) 0 1 2 3 4 5 1 0 3 2 5 4 2 3 4 5 0 1 3 2 5 4 1 0 4 5 0 1 2 3 5 4 1 0 3 2 #t gosh> (call/cc (lambda (break) (latina (lambda (x) (print-board x 7) (break #t)) 7))) 0 1 2 3 4 5 6 1 0 3 2 5 6 4 2 3 0 1 6 4 5 3 4 5 6 0 1 2 4 2 6 5 1 0 3 5 6 1 4 2 3 0 6 5 4 0 3 2 1 #t
;
; latina.scm : ラテン方陣
;
; Copyright (C) 2010 Makoto Hiroi
;
(use srfi-1)
; ビット用高階関数
(define (bit-for-each func n)
(let loop ((n n))
(if (positive? n)
(let ((m (logand (- n) n)))
(func m)
(loop (logxor n m))))))
; リスト用高階関数
(define (list-for-each-with-index func ls)
(let loop ((i 0) (ls ls))
(cond ((pair? ls)
(func i (car ls))
(loop (+ i 1) (cdr ls))))))
; ベクタ用高階関数
(define (vector-fold-with-index func init vec)
(let loop ((i 0) (a init))
(if (= i (vector-length vec))
a
(loop (+ i 1)
(func i (vector-ref vec i) a)))))
; 盤面の表示
(define (print-board board size)
(let loop ((i 0))
(cond ((= i (* size size)) (newline))
(else
(if (zero? (modulo i size)) (newline))
(format #t "~D " (logcount (- (vector-ref board i))))
(loop (+ i 1))))))
; 標準形のラテン方陣を求める
(define (latina func size)
(define board (make-vector (* size size) #f))
(define xflag (make-vector size (- (expt 2 size) 1)))
(define yflag (make-vector size (- (expt 2 size) 1)))
(define (get-x pos) (modulo pos size))
(define (get-y pos) (quotient pos size))
(define (get-numbers pos)
(logand (vector-ref xflag (get-x pos))
(vector-ref yflag (get-y pos))))
(define (flag-rev! vec pos num)
(vector-set! vec
pos
(logxor (vector-ref vec pos) num)))
(define (number-set! pos num)
(vector-set! board pos num)
(flag-rev! xflag (get-x pos) num)
(flag-rev! yflag (get-y pos) num))
(define (number-delete! pos)
(let ((num (vector-ref board pos)))
(vector-set! board pos #f)
(flag-rev! xflag (get-x pos) num)
(flag-rev! yflag (get-y pos) num)))
; 初期化
(define (init-data)
(list-for-each-with-index
(lambda (i pos) (number-set! pos (ash 1 i)))
(iota size))
(list-for-each-with-index
(lambda (i pos) (number-set! pos (ash 2 i)))
(iota (- size 1) size size)))
(define (solve pos)
(if (= pos (* size size))
(func board)
(let ((m (vector-ref board pos)))
(cond ((not m)
(bit-for-each
(lambda (num)
(number-set! pos num)
(solve (+ pos 1))
(number-delete! pos))
(get-numbers pos)))
(else (solve (+ pos 1)))))))
;
(init-data)
(solve 0))