HOME |
18. 非決定性 |
もうひとつの Scheme 入門 |
A-2. 関数電卓 |
download |
書き込む |
8 x 8 のチェス盤の場合、解は 92 個あります。チェス盤の対称操作を考慮すると独立の解は 12 個になります。 ここでは、対称操作を考慮した解を求めてみます。 このパズルを解くプログラムには再帰関数がふんだんに出てくるので Scheme 向きの問題といえます。 Scheme である程度大きいプログラムを書くとどんな感じになるか見てください。

図1:0 から (n-1) の整数の順列を作り、数が行、数の位置が列を表すようにすれば、 縦横の利きは避けることができる。
新しく置かれた Queen の行の位置を p とすると、隣の列での斜めの利きは (p+1), (p-1) となり、列の移動に伴って1つ増えるか、1つ減るかします。従って、新しく置かれた Queen q がすでに盤上にある Queen qs とぶつかるかどうかは次の関数で調べることができます。(2.1. の方針に従って 縦横はぶつからないことが保証されているとします。)
[code 1]
01: (define (conflict? q qs) 02: (let loop((inc (1+ q)) (dec (1- q)) (ls0 qs)) 03: (if (null? ls0) 04: #f 05: (let ((c (car ls0))) 06: (or 07: (= c inc) 08: (= c dec) 09: (loop (1+ inc) (1- dec) (cdr ls0)))))))関数 conflict? は Queen の利きが衝突すれば #t をしなければ #f を返します。 ここで (1+ x), (1- x) は引数 x に1を加える、1 を引く関数です。
[code 2]
01: (letrec ((q-sethash (lambda (qs) ;; registrate on the hash table 02: (let ((qi (q2int n qs))) 03: (if (eq? (hash-table/get qsol qi 'not-yet) 'not-yet) 04: (begin 05: (for-each 06: (lambda (op) 07: (hash-table/put! qsol (q2int n (op qs)) #f)) 08: (list t90 t180 t270 reverse usd d1 d2)) 09: (hash-table/put! qsol qi #t)))))) 10: 11: 12: (q-add (lambda (qs i pool) ;; adding new queen 13: (if (= i n) 14: (q-sethash qs) 15: (for-each (lambda (x) 16: (or (conflict? x qs) 17: (q-add (cons x qs) (1+ i) (remove x pool)))) 18: pool))))) 19: 20: (q-add () 0 (range n)))q-add はすでに盤上にある Queen のリスト qs と置かれている Queen の数 i とまだ使われていない行のリスト pool の3つの引数をとります。置かれている Queen の数が n に等しいときは、q-sethash 補助関数を使って解をハッシュ表に登録します。そうでなければ、pool に残っている行について、すでに置かれている Queen と衝突するか調べ、衝突しなければ、それを盤上に加え、pool からそれを取り除いて、 q-add を繰り返します。 (remove x ls) は ls から x を取り除いたリストを返す関数です。付録の nqueen.scm にその定義があります。
q-sethash では、まず、解を q2int で整数に変えてハッシュ表のキーにします。 次に、解がすでにハッシュ表に登録されているか調べます。 もし、登録されていなければ、対称操作で生ずる盤面を値 #f で登録し、その後、もとの盤面を 値 #t で登録します。こうすると、対称操作で互いの変換できない独立した解のみが値 #t でハッシュ表に登録されます。
N Queens を解く関数 (queen n) は [code 3] のようになります。 24 行目の (q-add () 0 (range n))) でを探し始め、25--27 行目で独立解を選び出し、 28 行目でプロットします。 値が何も返らないと落ち着かないので、解の数を返すようにします。
[code 3]
[code 4]
01: (define (queen n)
02: (let ((qsol (make-eqv-hash-table))
03: (qlist '()))
04: (letrec ((q-sethash (lambda (qs) ;; registrate on the hash table
05: (let ((qi (q2int n qs)))
06: (if (eq? (hash-table/get qsol qi 'not-yet) 'not-yet)
07: (begin
08: (for-each
09: (lambda (op)
10: (hash-table/put! qsol (q2int n (op qs)) #f))
11: (list t90 t180 t270 reverse usd d1 d2))
12: (hash-table/put! qsol qi #t))))))
13:
14:
15: (q-add (lambda (qs i pool) ;; adding new queen
16: (if (= i n)
17: (q-sethash qs)
18: (for-each (lambda (x)
19: (or (conflict? x qs)
20: (q-add (cons x qs) (1+ i) (remove x pool))))
21: pool)))))
22:
23: (q-add () 0 (range n)))
24: (hash-table/for-each qsol ;; pick up distinct solutions
25: (lambda (k v)
26: (if v (set! qlist (cons (int2q n k) qlist)))))
27: (qplot n qlist) ;; plotting the distinct solutions
28: (length qlist)))
2.5. 対称操作
対称操作には、動かさないという操作のほかに、90, 180, 270 度回転、上下、左右、対角線(2つ)反転
の7つがあります。回転は、N Queens パズルの性質から、0 -- (n-1) の数の列の位置を返すと 90 度回転になります。
対称操作関数を [code 4] に挙げます。
01: ;;; symmetry operations
02: ;; turn 90 degree
03: (define (t90 qs)
04: (let ((n (length qs)))
05: (let loop ((ls1 ()) (i 0))
06: (if (= i n)
07: ls1
08: (loop (cons (position i qs) ls1) (1+ i))))))
09:
10: ;; turn 180 degree
11: (define (t180 qs)
12: (usd (reverse qs)))
13:
14: ;; turn 270 degree
15: (define (t270 qs)
16: (t90 (t180 qs)))
17:
18: ;; up side down
19: (define (usd qs)
20: (let ((n (1- (length qs))))
21: (map (lambda (x) (- n x)) qs)))
22:
23: ;; reflection on diagonal 1
24: (define (d1 qs)
25: (reverse (t90 qs)))
26:
27: ;; reflection on diagonal 2
28: (define (d2 qs)
29: (usd (t90 qs)))
2.6. 結果の表示
結果の表示には gnuplot を使います。
MIT-Scheme には graphic が付いていますが、gnuplot で書かせたほうが簡単です。
表示の部分のコードを [code 5] に示します。i 番目の解に対して qi.dat という
データファイルをつくり、それを queen.plt というコマンドファイルでプロットします。
gnuplot のコンソールに
load 'queen.plot'
と与えると、図に示すプロットが表示され、ダイアログで 'OK' をクリックすると次の解が表示されます。

01: ;;; plotting using gnuplot 02: ;; drawing grid 03: (define (draw-grid n) 04: (let ((p (number->string (1+ n)))) 05: (let loop((i 0)) 06: (if (<= i n) 07: (let ((s (number->string (1+ i)))) 08: (print-lines 09: (string-append "set arrow from " s ", 1 to " s ", " p " nohead lt 5") 10: (string-append "set arrow from 1, " s " to " p ", " s " nohead lt 5")) 11: (loop (1+ i))))))) 12: 13: 14: ;; plotting data file of the solution 15: (define (plot-queen len) 16: (let loop((i 0)) 17: (if (< i len) 18: (begin 19: (print-lines 20: (string-append "set title \"solution: " (number->string (1+ i)) "\"") 21: (string-append "plot \"q" (number->string i) ".dat\" title \"queen\" with point pointsize 3") 22: "pause -1 \"Hit return to continue\"") 23: (loop (1+ i)))))) 24: 25: ;; writing data files 26: (define (q-write-dat qls) 27: (let loop((i 0) (ls qls)) 28: (if (pair? ls) 29: (begin 30: (with-output-to-file (string-append "q" (number->string i) ".dat") 31: (lambda () 32: (let rec((j 0) (ls1 (car ls))) 33: (if (pair? ls1) 34: (begin 35: (print-lines (string-append (number->string (+ j 1.5)) " " (number->string (+ (car ls1) 1.5)))) 36: (rec (1+ j) (cdr ls1))))))) 37: (loop (1+ i) (cdr ls)))))) 38: 39: ;; making a command file for gnuplot 40: (define (qplot n qls) 41: (q-write-dat qls) 42: (with-output-to-file "queen.plt" 43: (lambda () 44: (let ((s (number->string (+ n 2)))) 45: (print-lines 46: "reset" 47: "set size square" 48: (string-append "set xrange [0:" s "]") 49: (string-append "set yrange [0:" s "]")) 50: (draw-grid n) 51: (plot-queen (length qls)))))) 52:
処理時間を比較するには with-timing を使います。 例えば、(queen 10) の速度を計測するには以下のようにします。 計算に要した時間、ごみ集めに要した時間、合計の時間が表示されます。
(with-timings (lambda () (queen 10)) (lambda (run-time gc-time real-time) (write (internal-time/ticks->seconds run-time)) (write-char #\space) (write (internal-time/ticks->seconds gc-time)) (write-char #\space) (write (internal-time/ticks->seconds real-time)) (newline)))
ソースコードを見ていただくとわかるように、queen を除く全ての関数が 20 行以下で書かれています。 Scheme ではこのように小さい関数を積み上げてプログラムを作っていきます。

01: ;;; the main function 02: (define (queen_sym n) 03: (let ((qsol (make-eqv-hash-table)) 04: (qlist '())) 05: (letrec ((q-sethash (lambda (qs) ;; registrate on the hash table 06: (let ((qi (q2int n qs))) 07: (if (eq? (hash-table/get qsol qi 'not-found) 'not-found) 08: (let ((sym (map (lambda (op) (q2int n (op qs))) 09: (list t90 t180 t270 reverse usd d1 d2)))) 10: (if (memv qi sym) 11: (begin 12: (for-each 13: (lambda (v) 14: (hash-table/put! qsol v #f)) 15: sym) 16: (hash-table/put! qsol qi #t)))))))) 17: 18: (q-add (lambda (qs i pool) ;; adding new queen 19: (if (= i n) 20: (q-sethash qs) 21: (for-each (lambda (x) 22: (or (conflict? x qs) 23: (q-add (cons x qs) (1+ i) (remove x pool)))) 24: pool))))) 25: 26: (q-add () 0 (range n))) 27: (hash-table/for-each qsol ;; pick up distinct solutions 28: (lambda (k v) 29: (if v (set! qlist (cons (int2q n k) qlist))))) 30: (qplot n qlist) ;; plotting the distinct solutions 31: (length qlist)))
HOME |
18. 非決定性 |
もうひとつの Scheme 入門 |
A-2. 関数電卓 |
download |
書き込む |