こんなにgoto文だらけのプログラムがよく動くと感心するが, それがこの本のアルゴリズムの特徴だ. とにかくプログラムが動くようになれば, その機能が理解できるという期待から, 私はいつも実装に心掛けている.
今回お目にかけるこのプログラムも, 中に説明は書いてないが, TAOCPの記述に忠実に実装してあるので, 本文と読み較べてほしい. もっともその方の説明も分り難いが.
プログラムリストについているのは, Waerden(3,3;9)用のデータである.
(define (and1 n)
(if (even? n) 0 1))
(define (xor1 n)
((if (even? n) + -) n 1))
(define (rsh1 n)
(fix:lsh n -1))
(define (iverson b) (if b 1 0))
;Waerden(3,3;9)用のデータ
(define n 9) (define m 32) ;waerden(3,3;9)
(define ls '(3 11 19 7 13 19 5 11 17 3 9 15 11 15 19 9 13 17
7 11 15 5 9 13 3 7 11 15 17 19 13 15 17 11 13 15 9 11 13 7 9
11 5 7 9 3 5 7 2 10 18 6 12 18 4 10 16 2 8 14 10 14 18 8 12
16 6 10 14 4 8 12 2 6 10 14 16 18 12 14 16 10 12 14 8 10 12
6 8 10 4 6 8 2 4 6) )
(define ws '
(0 0 1 17 2 18 3 19 4 20 5 21 6 22 7 23 0 0 0 0))
(define link '
(0 8 9 10 11 12 0 0 13 14 15 0 0 16 0 0 0 24 25 26 27 28 0 0
29 30 31 0 0 32 0 0 0))
(define start '(96 93 90 87 84 81 78 75 72 69 66 63 60 57 54
51 48 45 42 39 36 33 30 27 24 21 18 15 12 9 6 3 0))
;途中の様子を出力する関数
(define (printnext next h t)
(let ((ring (list)))
(define (ploop)
(if (eq? h t) (display (reverse (cons t ring)))
(begin (set! ring (cons h ring))
(set! h (list-ref next h)) (ploop))))
(ploop)))
(define (printcl j)
(define (pin x)
(string->symbol (string-append
(number->string (quotient x 2))
(list-ref '("+" "-") (and1 x)))))
(display (map (lambda (x) (pin (list-ref ls x)))
(a2b (list-ref start j) (list-ref start (- j 1))))))
(define (printx xs)
(display (map (lambda (x) (if (< x 0) '- x)) xs)))
(define d 0) (define h 0) (define t 0) (define f 0)
(define k 0) (define p 0) (define b 0) (define l 0)
(define j 0) (define j1 0) (define i 0) (define l1 0)
(define q 0)
(define xs (map (lambda (x) 0) (a2b 0 (+ n 1))))
(define next (map (lambda (x) 0) (a2b 0 (+ n 1))))
(define hs (map (lambda (x) 0) (a2b 0 (+ n 1))))
(define ms (map (lambda (x) 0) (a2b 0 (+ m 1))))
(call-with-current-continuation
(lambda (exit)
(define (d1)
(list-set! ms 0 0)
(set! d 0)
(set! h 0)
(set! t 0)
(do ((k n (- k 1))) ((= k 0))
(list-set! xs k -1)
(if (or (not (= (list-ref ws (* 2 k)) 0))
(not (= (list-ref ws (+ (* 2 k) 1)) 0)))
(begin
(list-set! next k h) (set! h k)
(if (= t 0) (set! t k)))))
(if (not (= t 0)) (list-set! next t h))
(d2))
(define (d2)
(newline) (if (not (= t 0)) (printnext next h t))
(printx (cdr xs)) ;xsを出力
(if (= t 0) (exit 'satisfiable)
(begin (set! k t) (d3))))
(define (ex135 l)
(let ((j (list-ref ws l)))
(define (un0)
(set! p (+ (list-ref start j) 1))
(un1))
(define (un1)
(if (= p (list-ref start (- j 1))) 1 (un2)))
(define (un2)
(if (= (list-ref xs (rsh1 (list-ref ls p)))
(and1 (list-ref ls p)))
(begin (set! p (+ p 1)) (un1)) (un3)))
(define (un3)
(set! j (list-ref link j))
(if (= j 0) 0 (un0)))
(if (not (= j 0)) (un0) 0)))
(define (d3)
(set! h (list-ref next k))
(let ((f0 (ex135 (* 2 h))) (f1 (ex135 (+ (* 2 h) 1))))
(set! f (+ f0 (* 2 f1))) )
(cond ((= f 3) (display (list 'un
(string-append (number->string h) "+")
(string-append (number->string h) "-"))) (d7))
((or (= f 1) (= f 2))
(display (list 'un (string-append (number->string h)
(list-ref '(0 "+" "-") f))))
(list-set! ms (+ d 1) (+ f 3)) (set! t k) (d5))
((not (= h t)) (set! k h) (d3))
(else (d4))))
(define (d4)
(set! h (list-ref next t))
(list-set! ms (+ d 1)
(iverson (or (= (list-ref ws (* 2 h)) 0)
(not (= (list-ref ws (+ (* 2 h) 1)) 0)))))
(d5))
(define (d5)
(set! d (+ d 1))
(list-set! hs d h)
(set! k h)
(if (= t k) (set! t 0)
(begin (list-set! next t (list-ref next k))
(set! h (list-ref next k))))
(d6))
(define (ex136)
(define (ud0)
(set! j1 (list-ref link j))
(set! i (list-ref start j))
(set! p (+ i 1))
(ud1))
(define (ud1)
(if (= (list-ref xs (rsh1 (list-ref ls p)))
(and1 (list-ref ls p)))
(begin (set! p (+ p 1)) (ud1))
(ud2)))
(define (ud2)
(set! l1 (list-ref ls p))
(list-set! ls p l)
(list-set! ls i l1)
(ud3))
(define (ud3)
(set! p (list-ref ws l1))
(set! q (list-ref ws (xor1 l1)))
(if (or (not (= p 0)) (not (= q 0))
(>= (list-ref xs (rsh1 l1)) 0))
(ud5) (ud4)))
(define (ud4)
(if (= t 0) (begin (set! t (rsh1 l1)) (set! h (rsh1 l1))
(list-set! next t h))
(begin (list-set! next (rsh1 l1) h) (set! h (rsh1 l1))
(list-set! next t h)))
(ud5))
(define (ud5)
(list-set! link j p)
(list-set! ws l1 j)
(ud6))
(define (ud6)
(printcl j)
(set! j j1)
(if (not (= j 0)) (ud0)))
(set! l (+ (* 2 k) b))
(set! j (list-ref ws l))
(list-set! ws l 0)
(if (not (= j 0)) (ud0)))
(define (d6)
(set! b (modulo (+ (list-ref ms d) 1) 2))
(list-set! xs k b)
(ex136)
(d2))
(define (d7loop)
(if (>= (list-ref ms d) 2) (begin
(set! k (list-ref hs d))
(list-set! xs k -1)
(if (or (not (= (list-ref ws (* 2 k)) 0))
(not (= (list-ref ws (+ (* 2 k) 1)) 0)))
(begin (list-set! next k h)
(set! h k)
(list-set! next t h)))
(set! d (- d 1)) (d7loop))))
(define (d7)
(set! t k)
(d7loop)
(d8))
(define (d8)
(if (> d 0) (begin
(list-set! ms d (- 3 (list-ref ms d)))
(set! k (list-ref hs d)) (d6))
(exit 'unsatisfiable)))
(d1)))
このアルゴリズムの出力を, TAOCPにあるのと同じ場所まで書いてみるとこうなる. (プログラムの実際の出力はもっと冗長だが, 不要な空白など手でけしてある.) 左からアクティブリング, xの値, unはユニットになったリテラル(これが同じ変数の正負のリテラルだとバックトラックに入る,) 書き換えた
項を示す.
(1234567) - - - - - - - - - 2+1+3+ 3+1+5+ 4+1+7+ 5+1+9+
(234567) 0 - - - - - - - - 3+1+2+ 3+2+4+ 4+2+6+ 5+2+8+
(34567) 0 0 - - - - - - -(un 3+) 4-3-5- 5-3-7- 6-3-9-
(4567) 0 0 1 - - - - - - 6+2+4+ 7+1+4+ 5+4+6+ 6+4+8+
(567) 0 0 1 0 - - - - -(un 6+) 9-3-6- 7-6-8-
(975) 0 0 1 0 - 1 - - -(un 9-)
(75) 0 0 1 0 - 1 - - 0(un 7+) 8-6-7- 8-7-9-
(85) 0 0 1 0 - 1 1 - 0(un 8-)
(5) 0 0 1 0 - 1 1 0 0(un 5+5-) 5-3-4- 5-4-6- 6-4-8-
(69785) 0 0 1 1 - - - - -(un 5-) 4+5+6+ 8+2+5+ 9+1+5+
6+5+7+ 7+5+9+
(6978) 0 0 1 1 0 - - - -(un 9+) 6-3-9-
3行目の2番目の項はTAOCPのと違う. もちろん向こうが違っている. クヌース先生には連絡済みだ.
0 件のコメント:
コメントを投稿