問題4.50-4.51

sicp

amb評価器をいじります。

4.50

rambを作ります。まずanalyzeに次を追加。

...
((ramb? exp) (analyze-ramb exp))
...

こんなのも作ります。

(define (ramb? exp) (tagged-list? exp 'ramb))
(define (ramb-choices exp) (cdr exp))

最後にanalyze-rambをanalyze-ambを参考に作ります。

(define (analyze-ramb exp)
  (let ((cprocs (map analyze (ramb-choices exp))))
    (lambda (env succeed fail)
      (define (del-list-item lst n)
        (cond ((null? lst) '())
              ((= n 0) (cdr lst))
              (else (cons (car lst)
                          (del-list-item (cdr lst) (- n 1))))))
      (define (try-next choices)
        (if (null? choices)
            (fail)
            (let* ((rand-num (random (length choices)))
                   (cproc (list-ref choices rand-num)))
              (cproc env
                     succeed
                     (lambda ()
                       (try-next (del-list-item choices rand-num)))))))
      (try-next cprocs))))

実行します。

;;; Amb-Eval input:
(ramb 1 2 3 4)
;;; Starting a new problem 
;;; Amb-Eval value:
2

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
3

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
1

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
4

;;; Amb-Eval input:
try-again
;;; There are no more values of
(ramb 1 2 3 4)

できました。4.49のAlyssaの問題はrambを使うと次のようになります。

;;; Amb-Eval input:
(parse '(the big cat sleeps with a student))
;;; Starting a new problem 
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adj-phrase (adj thin) (noun cat))) (verb-phrase (verb lectures) (prep-phrase (prep by) (simple-noun-phrase (article a) (noun student)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article the) (adj-phrase (adj thin) (noun cat))) (verb-phrase (verb lectures) (prep-phrase (prep by) (simple-noun-phrase (article a) (noun class)))))

parseによる生成文はランダムですが、try-againすると前の方がいっしょになりますね。縦型探索だから仕方ないのかな。まあrambできたしこれでいいや。

4.51

失敗してももとに戻らない代入は確かに便利ですね。どれくらい探索してるのかとか調べられるんじゃないでしょうか。
analyzeに以下を追加。

...
((permanent-assignment? exp)
 (analyze-permanent-assignment exp))
...

述語とかを書く。

(define (permanent-assignment? exp)
  (tagged-list? exp 'permanent-set!))
(define (permanent-assignment-variable exp) (cadr exp))
(define (parmanent-assignment-value exp) (caddr exp))
(define (make-permanent-assignment var val)
  (list 'permanent-set! var val))

analyze-assignmentを参考にanalyze-permanent-assignmentを書きます。ちなみに、analyze-sequenceとanalyze-assignmentですが教科書のだと動かないので下のようにしています。

(define (analyze-sequence exps)
  (define (sequentially a b)
    (lambda (env succeed fail)
      (a env
         (lambda (a-value fail2)
           (b env succeed fail2))
         fail)))
  (define (loop first-proc rest-procs)
    (if (null? rest-procs)
        first-proc
        (loop (sequentially first-proc (car rest-procs))
              (cdr rest-procs))))
  (let ((procs (map analyze (scan-out-defines exps))))
    (if (null? procs)
        (error "Empty sequence -- ANALYZE"))
    (loop (car procs) (cdr procs))))
(define (analyze-assignment exp)
  (define (get-variable-value var env)
    (define (env-loop env)
      (scan-frame env
                  var
                  (lambda (x) (env-loop (enclosing-environment x)))
                  (lambda (x) (car x))))
    (env-loop env))
  (let ((var (assignment-variable exp))
        (vproc (analyze (assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)
               (let ((old-value
                      (get-variable-value var env))); if you use lookup-variable-value, get error.
                 (set-variable-value! var val env)
                 (succeed 'ok
                          (lambda ()
                            (set-variable-value! var
                                                 old-value
                                                 env)
                            (fail2)))))
             fail))))

make-procedureでscan-out-definesを使おうとすると、既に実行手続き形式になっているのでうまく行きません。なので、まだ生の式の状態であるanalyze-sequenceの中でscan-out-definesを使っています。
また、old-valueを得るときにlookup-variable-valueを使おうとすると、scan-out-definesのせいで変数が'*unassigned*に束縛されているのでエラーになってしまいます。代わりにエラー判定を行わないget-variable-valueを使っています。
これがちゃんと全ての要件を満たしているかどうかは未確認です。とりあえず今のところちゃんと動きはします。

じゃあanalyze-permanent-assignmentを作ります。値を戻す処理を省けばいいです。

(define (analyze-permanent-assignment exp)
  (let ((var (permanent-assignment-variable exp))
        (vproc (analyze (permanent-assignment-value exp))))
    (lambda (env succeed fail)
      (vproc env
             (lambda (val fail2)
               (set-variable-value! var val env)
               (succeed 'ok fail2))
             fail))))

確認します。

;;; Amb-Eval input:
(define count 0)
;;; Starting a new problem 
;;; Amb-Eval value:
ok

;;; Amb-Eval input:
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (permanent-set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))
;;; Starting a new problem 
;;; Amb-Eval value:
(a b 2)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 3)

;;; Amb-Eval input:
(set! count 0)
;;; Starting a new problem 
;;; Amb-Eval value:
ok

;;; Amb-Eval input:
(let ((x (an-element-of '(a b c)))
      (y (an-element-of '(a b c))))
  (set! count (+ count 1))
  (require (not (eq? x y)))
  (list x y count))
;;; Starting a new problem 
;;; Amb-Eval value:
(a b 1)

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(a c 1)
4.50の補足

ところでan-element-ofを見て思ったんですが、昨日の4.49はan-element-ofを使うとすごく簡単に書けたような気がします。
今日やった4.50もリストからrandomに要素を取ってくるan-random-element-ofみたいなのを書けばできるような気がします。でもこの場合単にambをrambにすると、抜き出してくる要素がリストの左から右に飛び飛びの値、そのあと右から左に順に取ってくる、みたいな動きになってしまいます。つまり、'(1 2 3 4)だったら[1,3,2,4]みたいな順に抜き出すことができません。
なので与えられたリストの順をrandomに並べたものをan-element-ofで抜き出してくればいいように思います。そう書いてみると、

(define (an-random-element-of lst)
  (define (del-list-item lst n)
    (cond ((null? lst) '())
          ((= n 0) (cdr lst))
          (else (cons (car lst)
                      (del-list-item (cdr lst) (- n 1))))))
  (define (random-mix-list lst)
    (if (null? lst)
        '()
        (let ((rand-num (random (length lst))))
        (cons (list-ref lst rand-num)
              (random-mix-list (del-list-item lst rand-num))))))
  (let rec ((rand-list (random-mix-list lst)))
    (require (not (null? rand-list)))
    (amb (car rand-list) (rec (cdr rand-list)))))

(define (parse-word word-list)
  (require (not (null? *unparsed*)))
  (require (memq (car *unparsed*) (cdr word-list)))
  (set! *unparsed* (cdr *unparsed*))
  (list (car word-list)
        (an-random-element-of (cdr word-list))))

こんな風に書けると思います。an-random-element-ofを実行すると、

;;; Amb-Eval input:
(an-random-element-of '(1 2 3 4 5 6 7 8))
;;; Starting a new problem 
;;; Amb-Eval value:
3

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
8

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
7

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
2

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
6

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
5

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
1

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
4

;;; Amb-Eval input:
try-again
;;; There are no more values of
(an-random-element-of '(1 2 3 4 5 6 7 8))

とrandomにリストの要素を全部取り出してくれます。parseすると、

;;; Amb-Eval input:
(parse '(the cat eats in the class))
;;; Starting a new problem 
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb-phrase (verb eats) (prep-phrase (prep by) (simple-noun-phrase (article a) (noun professor)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb-phrase (verb eats) (prep-phrase (prep by) (simple-noun-phrase (article a) (noun student)))))

;;; Amb-Eval input:
try-again
;;; Amb-Eval value:
(sentence (simple-noun-phrase (article a) (noun cat)) (verb-phrase (verb eats) (prep-phrase (prep by) (simple-noun-phrase (article a) (noun cat)))))

で上の方で作った4.50のものと同じ性能になっています。


眠いのでここまで。