SICP 読み (201) 4.2.2 遅延評価の解釈系
問題 4.34
無限リストの事は忘れて、とりあえず出力できるようにしてみる。方向性としては
- make-procedure において parameters が '(m) で body が '(m x y) なら cons 認定
- cons 認定の場合は 'cons というタグを付ける
- compound-procedure? にて (tagged-list? p 'cons) も真を戻させる
これで user-print なソレにおいて cons なナニの切り分けができるはず。でも無理矢理スギってか微妙。特に cons 認定する所が一番微妙。もっと頭がええヤリ方があるはずなんだろうけどなぁ。(駄目
で、user-print において cons 認定したら値なリストを戻す手続きを書いてそれに渡してやれば良いだろう、と。繰り返しますが無限リストは忘れています。
(define (list-print obj)
(define (inner-car l)
(force-it (eval-sequence (procedure-body l)
(extend-environment (procedure-parameters l)
(list-of-delayed-args
(list (make-lambda
'(p q)
'(p)))
the-global-environment)
(procedure-environment l)))))
(define (inner-cdr l)
(force-it (eval-sequence (procedure-body l)
(extend-environment (procedure-parameters l)
(list-of-delayed-args
(list (make-lambda
'(p q)
'(q)))
the-global-environment)
(procedure-environment l)))))
(if (null? (inner-cdr obj))
'()
(cons (inner-car obj)
(list-print (inner-cdr obj)))))って、これ複雑なリストは無視だな。こんなカンジ?? (一部のみ
(if (null? (inner-cdr obj))
'()
(cons (let ((car-obj (inner-car obj)))
(if (cons? car-obj)
(list-print car-obj)
car-obj))
(list-print (inner-cdr obj))))微妙。試験は別途。
試験検討中 (ちょっとづつ追記
list-print な試験検討中に考慮の範疇に入っていない部分を発見。cdr が cons なリストかどうかを判定してないッス (って直上で無視って書いてるな。それさえ忘れるほどテンパってるのか何も考えてないのか、それとも報告書作りながらこんな事してるから微妙なのか)。しかも上のコード、cons が cond になってる。(駄目
しかも無理矢理試験してみた所、list-print の中で global-environment 使ってしまっているんですが通用せんかった。他にも微妙な部分が沢山。とりあえず以下に複雑リスト無視な修正版を。
(define (list-print obj)
(define (inner-car l)
(force-it (eval-sequence (procedure-body l)
(extend-environment (procedure-parameters l)
(list-of-delayed-args
(list (make-lambda
'(p q)
'(p)))
(procedure-environment l))
(procedure-environment l)))))
(define (inner-cdr l)
(force-it (eval-sequence (procedure-body l)
(extend-environment (procedure-parameters l)
(list-of-delayed-args
(list (make-lambda
'(p q)
'(q)))
(procedure-environment l))
(procedure-environment l)))))
(if (null? (inner-cdr obj))
(cons (inner-car obj) '())
(cons (let ((car-obj (inner-car obj)))
(if (cons? car-obj)
(list-print car-obj)
car-obj))
(list-print (inner-cdr obj)))))よく考えりゃ、こうすりゃ良いのか。(一部のみ
(define (list-parse-dispatch l)
(if (cons? l)
(list-print l)
l))
(if (null? (innder-cdr obj))
(cons (inner-car obj) '())
(cons (list-parse-dispatch (inner-car obj))
(list-parse-dispatch (inner-cdr obj))))わははは (何
でも試験は未実施。
まだまだ続く
(1 . 2) みたいに、とか (1 2 (3 4)) とか微妙。あら、cons してるから大丈夫なのかなぁ。何も考えずに作ってセイフなんだったら笑うぞ。
って試験普通にパスしてるし。現状の実装と試験を以下に。(一部のみ)
(define (make-procedure parameters body env)
(if (and (equal? parameters '(m))
(equal? body '((m x y))))
(list 'cons parameters body env)
(list 'procedure parameters body env)))
(define (compound-procedure? p)
(or (tagged-list? p 'procedure)
(tagged-list? p 'cons)))
(define (cons? p)
(tagged-list? p 'cons))
(define (list-print obj)
(define (inner-car l)
(inner-eval l (list (make-lambda '(p q) '(p)))))
(define (inner-cdr l)
(inner-eval l (list (make-lambda '(p q) '(q)))))
(define (inner-eval l lambda)
(force-it (eval-sequence (procedure-body l)
(extend-environment (procedure-parameters l)
(list-of-delayed-args
lambda
(procedure-environment l))
(procedure-environment l)))))
(define (list-parse-dispatch l)
(if (cons? l)
(list-print l)
l))
(if (null? (inner-cdr obj))
(cons (inner-car obj) '())
(cons (list-parse-dispatch (inner-car obj))
(list-parse-dispatch (inner-cdr obj)))))
(define (user-print object)
(if (compound-procedure? object)
(if (cons? object)
(display (list-print object))
(display (list 'compound-procedure
(procedure-parameters object)
(procedure-body object)
'<procedure-env>)))
(display object)))試験が以下。
("4.34 (3)"
("list-print"
(let ((env (setup-environment)))
(actual-value '(define (cons x y) (lambda (m) (m x y))) env)
(actual-value '(define (car z) (z (lambda (p q) p))) env)
(actual-value '(define (cdr z) (z (lambda (p q) q))) env)
(let ((obj (actual-value '(cons 1 (cons 2 '())) env)))
(assert-equal '(1 2) (list-print obj))
)
(let ((obj (actual-value '(cons 1 2) env)))
(assert-equal '(1 . 2) (list-print obj))
)
(let ((obj (actual-value '(cons 1 (cons (cons 2 3) (cons 4 '()))) env)))
(assert-equal '(1 (2 . 3) 4) (list-print obj))
)
)
)
("cons?"
(assert-true (cons? '(cons a b)))
(assert-false (cons? '(procedure a b)))
)
("compound-procedure?"
(assert-true (compound-procedure? '(cons a b)))
(assert-true (compound-procedure? '(procedure a b)))
(assert-false (compound-procedure? '(primitive a b)))
)
("cons list"
(let ((env (setup-environment)))
(actual-value '(define (cons x y) (lambda (m) (m x y))) env)
(actual-value '(define (car z) (z (lambda (p q) p))) env)
(actual-value '(define (cdr z) (z (lambda (p q) q))) env)
(actual-value '(define l (cons 1 2)) env)
(assert-equal 'cons (car (actual-value 'l env)))
(assert-equal '(m) (cadr (actual-value 'l env)))
(assert-equal '((m x y)) (caddr (actual-value 'l env)))
)
)
("make-procedure"
(let ((l '(lambda (m) (m x y)))
(l2 '(lambda (x) (x y z)))
(l3 '(lambda (m) (m y z))))
(assert-equal '(m) (cadr l))
(assert-equal '((m x y)) (cddr l))
(assert-equal 'cons (car (make-procedure (lambda-parameters l)
(lambda-body l)
'())))
(assert-equal 'procedure (car (make-procedure (lambda-parameters l2)
(lambda-body l2)
'())))
(assert-equal 'procedure (car (make-procedure (lambda-parameters l3)
(lambda-body l3)
'())))
)
)
("cons?"
(let ((S-ex '(lambda (m) (m x y) '())))
(assert-true (and (equal? (cadr S-ex) '(m))
(equal? (caddr S-ex) '(m x y))))
)
)
)無限リストはパスする予定。それにしてもコキタナイちからワザ感満点ッス。でも、ようやく amb に突入できる。そしてまだまだ先は長い。
さらに追記
assert-equal が SIGSEG なソレはバッファオーバーフローな感じがするなぁ。で、それは良いとして評価器の出力を確認してなかったのでやってみる。
;;; L-Eval input: (define (cons x y) (lambda (m) (m x y))) ;;; L-Eval value: ok ;;; L-Eval input: (define (car l) (l (lambda (p q) p))) ;;; L-Eval value: ok ;;; L-Eval input: (define (cdr l) (l (lambda (p q) q))) ;;; L-Eval value: ok ;;; L-Eval input: cons ;;; L-Eval value: (compound-procedure (x y) ((lambda (m) (m x y))) <procedure-env>) ;;; L-Eval input: car ;;; L-Eval value: (compound-procedure (l) ((l (lambda (p q) p))) <procedure-env>) ;;; L-Eval input: cdr ;;; L-Eval value: (compound-procedure (l) ((l (lambda (p q) q))) <procedure-env>) ;;; L-Eval input: (cons 1 2) ;;; L-Eval value: (1 . 2) ;;; L-Eval input: (cons 1 (cons 2 (cons 3 (cons 4 '())))) ;;; L-Eval value: (1 2 3 4) ;;; L-Eval input: (cons (cons 1 (cons 2 '())) (cons 3 (cons 4 '()))) ;;; L-Eval value: ((1 2) 3 4) ;;; L-Eval input: (cons 1 (cons (cons 2 3) (cons 4 '()))) ;;; L-Eval value: (1 (2 . 3) 4)
てか、4.3 節を読み始めてるんですが、頭がまだ慣れない。
