SICP 読み (233) 4.3.3 amb 評価器の実装

自宅マシンにて動作確認。4.51 と 4.52 なソレを盛り込んで動作確認。やはり

(define (find-divisor n test-divisor)
  (cond ((> (square test-divisor) n) n)
	((divides? test-divisor n) test-divisor)
	(else (find-divisor n (+ test-divisor 1)))))

を評価器に吸わせるとオチる。
で、試験を作ってどんどん掘り下げていくと

#!/usr/bin/env gosh

(use test.unit)
(require "ch4-ambeval")

(define-test-suite "amb"

  ("cond"
   ("cond->if"
    (let ((l '(cond ((> (square test-divisor) n) n)
		    ((divides? test-divisor n) test-divisor)
		    (else (find-divisor n (+ test-divisor 1))))))
      (assert-equal '(((> (square test-divisor) n) n)
		      ((divides? test-divisor n) test-divisor)
		      (else (find-divisor n (+ test-divisor 1))))
		    (cond-clauses l))
      (assert-true (not (cond-else-clause? (car (cond-clauses l)))))
      (assert-equal '(> (square test-divisor) n)
		    (cond-predicate (car (cond-clauses l))))
      (assert-equal '(((divides? test-divisor n) test-divisor)
		      (else (find-divisor n (+ test-divisor 1))))
		    (cdr (cond-clauses l)))
      (assert-equal '(n) (cond-actions (car (cond-clauses l))))
      (assert-true (last-exp? '(n)))
      (assert-equal 'n (car '(n)))
      (assert-equal 'n (first-exp '(n)))
      )
    )
   )
  )

の最後の試験にパスしない。と、ゆー事は first-exp が、という事でソースを見ると if-fail な盛り込みで

(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (first-exp exp) (cadr exp))
(define (second-exp exp) (caddr exp))

って (絶句
やれやれ。てーコトで if-fail なソレを以下のように修正。

(define (if-fail? exp) (tagged-list? exp 'if-fail))
(define (if-fail-first-exp exp) (cadr exp))
(define (if-fail-second-exp exp) (caddr exp))

(define (analyze-if-fail exp)
  (let ((first (analyze (if-fail-first-exp exp)))
	(second (analyze (if-fail-second-exp exp))))
    (lambda (env succeed fail)
      (first env
	     (lambda (first-v fail2)
	       (succeed first-v fail2))
	     (lambda ()
	       (second env
		       succeed
		       fail))))))

しかも直前エントリな prime-sum-pair が微妙。正しくは

(define (prime-sum-pair l1 l2)
  (let ((a (an-element-of l1))
        (b (an-element-of l2)))
    (require (prime? (+ a b)))
    (list a b)))

ですな。面倒臭いので一連のナニを上記含め以下に。

(define (smallest-divisor n)
  (find-divisor n 2))
(define (find-divisor n test-divisor)
  (cond ((> (square test-divisor) n) n)
	((divides? test-divisor n) test-divisor)
	(else (find-divisor n (+ test-divisor 1)))))
(define (divides? a b)
  (= (remainder b a) 0))
(define (prime? n)
  (= n (smallest-divisor n)))
(define (square n) (* n n))

(define (an-element-of items)
  (require (not (null? items)))
  (amb (car items) (an-element-of (cdr items))))

(define (require p)
  (if (not p) (amb)))

(define (prime-sum-pair l1 l2)
  (let ((a (an-element-of l1))
	(b (an-element-of l2)))
    (require (prime? (+ a b)))
    (list a b)))

(let ((pairs '()))
  (if-fail (let ((p (prime-sum-pair '(1 3 5 8) '(20 35 110))))
	     (permanent-set! pairs (cons p pairs))
	     (amb))
	   pairs))

で、それでも動かなくって、色々試していたんですが、ramb なソレが虫。

(use math.mt-random)
(define m (make <mersenne-twister> :seed (sys-time)))

(define (list-ref items n)
  (if (= n 0)
      (car items)
      (list-ref (cdr items) (- n 1))))
(define (remainder items n)
  (if (= n 0)
      (cdr items)
      (cons (car items) (remainder (cdr items) (- n 1)))))

(define (analyze-ramb exp)
  (let ((cprocs (map analyze (amb-choices exp))))
    (lambda (env succeed fail)
      (define (try-next choices)
	(if (null? choices)
	    (fail)
	    (let ((n (mt-random-integer m (length choices))))
	      ((list-ref choices n) 
	       env
	       succeed
	       (lambda () (try-next (remainder choices n)))))))
      (try-next cprocs))))

上記を削除し、無事動作。なんかソースの管理が無茶苦茶ッス。(とほほほ