exercise 4.5~4.10
ex4.5
こんな機能もあったのか、condよ・・・。
(define (cond-recipient-clause? clause) (eq? (cadr clause) '=>)) (define (cond-recipient clause) (caddr clause)) (define (expand-clauses clauses) (if (null? clauses) 'false ; no else clause (let ((first (car clauses)) (rest (cdr clauses))) (cond ((cond-else-clause? first) (if (null? rest) (sequence->exp (cond-actions first)) (error "ELSE clause isn't last -- COND->IF" clauses))) ((cond-recipient-clause? first) (list (make-lambda '(test) (list (make-if 'test (list (cond-recipient first) 'test) (expand-clauses rest)))) (cond-predicate first))) (else (make-if (cond-predicate first) (sequence->exp (cond-actions first)) (expand-clauses rest)))))))
結果は
;;; M-Eval input: (cond ((assoc 'b '((a 1) (b 2))) => cadr) (else false)) ;;; M-Eval value: 2
ちなみにassocとcadrはめんどいのでprimitive-proceduresのリストに放り込んで置いた。
ex4.6+4.8
やっとletか。
めんどくさいので4.8もまとめてやっちゃう。
(put 'eval 'let (lambda (exp env) (eval (let->combination exp) env))) (define (named-let? exp) (and (not (pair? (cadr exp))) (not (eq? (cadr exp) '() )))) (define (named-let-bindings exp) (caddr exp)) (define (named-let-var exp) (cadr exp)) (define (named-let-body exp) (cdddr exp)) (define (let-bindings exp) (cadr exp)) (define (let-body exp) (cddr exp)) (define (first-binding seq) (car seq)) (define (rest-bindings seq) (cdr seq)) (define (vars-of-bindings bindings) (if (null? bindings) '() (cons (car (first-binding bindings)) (vars-of-bindings (rest-bindings bindings))))) (define (exps-of-bindings bindings) (if (null? bindings) '() (cons (cadr (first-binding bindings)) (exps-of-bindings (rest-bindings bindings))))) (define (let->combination exp) (if (named-let? exp) (let ((name (named-let-var exp)) (bindings (named-let-bindings exp))) (sequence->exp (list (list 'define name (make-lambda (vars-of-bindings bindings) (named-let-body exp))) (cons name(exps-of-bindings bindings))))) (let ((bindings (let-bindings exp))) (cons (make-lambda (vars-of-bindings bindings) (let-body exp)) (exps-of-bindings bindings)))))
しかしこれでいいのか named let …
適当過ぎる匂いがする。
ex4.7
(put 'eval 'let* (lambda (exp env) (eval (let*->nested-lets exp) env))) (define (make-let bindings body) (cons 'let (cons bindings body))) (define (let*->nested-lets exp) (define (iter bindings) (make-let (list (first-binding bindings)) (if (null? (rest-bindings bindings)) (let-body exp) (list (iter (rest-bindings bindings)))))) (iter (let-bindings exp))) (define (let*->combination exp) (define (iter bindings) (list (make-lambda (list (car (first-binding bindings))) (if (null? (rest-bindings bindings)) (let-body exp) (list (iter (rest-bindings bindings)))) (cadr (first-binding bindings))))) (iter (let-bindings exp)))
結果は、
> (let*->nested-lets '(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))) (let ((x 3)) (let ((y (+ x 2))) (let ((z (+ x y 5))) (* x z)))) > (let ((x 3)) (let ((y (+ x 2))) (let ((z (+ x y 5))) (* x z)))) 39 > (let*->combination '(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))) ((lambda (x) ((lambda (y) ((lambda (z) (* x z)) (+ x y 5))) (+ x 2))) 3) > ((lambda (x) ((lambda (y) ((lambda (z) (* x z)) (+ x y 5))) (+ x 2))) 3) 39
今見て気づいたけど、bindingsが最初から空だとエラーになるな・・・。
つっても
(let* () (+ 1 1))
みたいなのは使われないよなぁ・・・
ex4.9
この問題やってて気づいたけどmzschemeにはwhileとかdolistとかが無いのか。というか、それが普通なのかしら。
以下に怪しいコード
;;(while <predicate> <bod>) (put 'eval 'while (lambda (exp env) (eval (expand-while exp) env))) (define (while-expr exp) (cadr exp)) (define (while-body exp) (cddr exp)) (define (expand-while exp) (sequence->exp (list (list 'define 'while-iter (make-lambda '() (list (make-if (while-expr exp) (sequence->exp (append (while-body exp) (list '(while-iter)))) 'true)))) ;;return value (list 'while-iter))))
まぁ動いてるし、いいや…
こんどマクロでの定義例でも見ておこう…
;;; M-Eval input: (let ((count 1) (result 1)) (while (< count 6) (set! result (* count result)) (set! count (+ count 1))) result) ;;; M-Eval value: 120
とまぁ動いてはいるようだ。
4.10
めんどい。パス。
というか別にやらんでもいい気がする・・・
