計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)
開発環境
- OS X Mavericks - Apple(OS)
- Emacs (CUI)、BBEdit - Bare Bones Software, Inc. (GUI) (Text Editor)
- Scheme (プログラミング言語)
- Gauche (処理系)
計算機プログラムの構造と解釈[第2版](ハロルド エイブルソン (著)、ジュリー サスマン (著)、ジェラルド・ジェイ サスマン (著)、Harold Abelson (原著)、Julie Sussman (原著)、Gerald Jay Sussman (原著)、和田 英一 (翻訳)、翔泳社、原書: Structure and Interpretation of Computer Programs (MIT Electrical Engineering and Computer Science)(SICP))の4(超言語的抽象)、4.1(超循環評価器)、4.1.2(式の表現)、導出された式、問題 4.10.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
問題 4.10.
コード(BBEdit, Emacs)
sample10.scm
#!/usr/bin/env gosh
;; -*- coding: utf-8 -*-
(define operations '())
(define (put op proc)
(cons (list op proc) operations))
(define (get op)
(define (inner operations)
(if (null? operations)
#f
(let ((pair (car operations)))
(if (eq? op (car pair))
(cadr pair)
(inner (cdr operations))))))
(inner operations))
(define (eval exp env)
(define (self-evaluating? exp)
(cond ((number? exp) #t)
((string? exp) #t)
(else #f)))
(define (variable? exp) (symbol? exp))
(define (application? exp) (pair? exp))
(define (operator exp) (car exp))
(define (operands exp) (cdr exp))
(define (no-operands? ops) (null? ops))
(define (first-operand ops) (car ops))
(define (rest-operands ops) (cdr ops))
(cond ((self-evaluating? exp) exp)
((variable? exp) (lookup-variable-value exp env))
((get (car exp))
((get (car exp)) exp env))
((application? exp)
(apply (eval (operator exp) env)
(list-of-values (operands exp) env)))
(else
(error "Unknown expression type -- EVAL" exp))))
(define (apply procedure arguments)
(cond ((primitive-procedure? procedure)
(apply-primitive-procedure procedure arguments))
((compound-procedure? procedure)
(eval-sequence
(procedure-body procedure)
(extend-environment
(procedure-parameters procedure)
arguments
(procedure-environment procedure))))
(else
(error
"Unknown procedure type -- APPLY" procedure))))
(define (install-quoted-package)
(define (text-of-quotation exp env) (cadr exp))
(put 'quote text-of-quotation))
(define (install-assignment-package)
(define (eval-assignment exp env)
(set-variable-value! (assignment-variable exp)
(eval (assignment-value exp) env)
env)
'ok)
(define (assignment-variable exp) (cadr exp))
(define (assignment-value exp) (caddr exp))
(put 'set! eval-assignment))
(define (install-definition-package)
(define (eval-definition exp env)
(define-variable! (definition-variable exp)
(eval (definition-value exp) env)
env)
'ok)
(define (definition-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (definition-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define make-lambda (get 'make-lambda))
(put 'define eval-definition))
(define (install-if-package)
(define (eval-if exp env)
(if (true? (eval (if-predicate exp) env))
(eval (if-consequent exp) env)
(eval (if-alternative exp) env)))
(define (true? a) (eq? a #t))
(define (if-predicate exp) (cadr exp))
(define (if-consequent exp) (caddr exp))
(define (if-alternative exp)
(if (not (null? (cdddr exp)))
(cadddr exp)
#f))
(define (make-if predicate consequent alternative)
(list 'if predicate consequent alternative))
(put 'make-if make-if)
(put 'if eval-if))
(define (install-lambda-package)
(define (lambda-parameters exp) (cadr exp))
(define (lambda-body exp) (cddr exp))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
(put 'make-lambda make-lambda)
(put 'lambda (lambda (exp env)
(make-procedure (lambda-parameters exp)
(lambda-body exp)
env))))
(define (install-begin-package)
(define (eval-sequence exps env)
(cond ((last-exp? exps) (eval (first-exp exps) env))
(else (eval (first-exp exps) env)
(eval-sequence (rest-exps exps) env))))
(define (begin-actions exp) (cdr exp))
(define (last-exp? seq) (null? (cdr seq)))
(define (first-exp seq) (car seq))
(define (rest-seq) (cdr seq))
(define (sequence->exp seq)
(cond ((null? seq) seq)
((last-exp? seq) (first-exp seq))
(else (make-begin seq))))
(define (make-begin seq) (cons 'begin seq))
(put 'sequence->exp sequence->exp)
(put 'make-begin make-begin)
(put 'begin (lambda (exp env)
(eval-sequence (begin-actions exp) env))))
(define (instll-cond-package)
(define (cond-clauses exp) (cdr exp))
(define (cond-else-clause? clause)
(eq? (cond-predicate clause) 'else))
(define (cond-predicate clause) (car clause))
(define (cond-actions clause) (cdr clause))
(define (cond->if exp)
(expand-clauses (cond-clauses exp)))
(define (expand-clauses clauses)
(if (null? clauses)
'false
(let ((first (car clauses))
(rest (cdr clauses)))
(if (cond-else-clause? first)
(if (null? rest)
(sequence->exp (cond-actions first))
(error "ELSE clause isn't last -- COND->IF"
clauses))
(make-if (cond-predicate first)
;; 問題 4.5 拡張構文を使えるようにする
(if (eq? (cadr first) '=>)
(list (caddr first) (cond-predicate first))
(sequence->exp (cond-actions first)))
(expand-clauses rest))))))
(define sequence->exp (get 'sequence->exp))
(define make-if (get 'make-if))
(put 'cond (lambda (exp env)
(eval (cond->if exp) env))))
;; 問題 4.4
(define (install-and-package)
(define (eval-and exp env)
(if (null? (cdr exp))
#t
(eval-sequence (cdr seq) env)))
(define (eval-sequence seq env)
(cond ((null? (cdr seq))
(if (eval (car seq) env)
(car seq)
#f))
((eval (car seq) env)
(eval-sequence (cdr seq) env))
(else #f)))
(put 'and eval-and))
(define (install-or-package)
(define (eval-or exp env)
(if (null? (cdr exp))
#f
(eval-sequence (cdr seq) env)))
(define (eval-sequence seq env)
(cond ((null? seq) #f)
((eval (car seq) env) (car seq))
(else
(eval-sequence (cdr seq) env))))
(put 'or 'eval-or))
;; 問題 4.6
(define (install-let-package)
(define (let-clauses exp) (cdr exp))
(define (let-vars-exps clauses) (car clauses))
(define (let-vars seq)
(if (null? (cdr seq))
(list (caar seq))
(cons (caar seq)
(let-vars (cdr seq)))))
(define (let-exps seq)
(if (null? (cdr seq))
(list (cadar seq))
(cons (cadar seq)
(let-exps (cdr seq)))))
(define (let-body clauses) (cdr clauses))
;; 問題 4.8
(define (let->combination exp)
(let ((clauses (let-clauses exp)))
(if (pair? (car clauses))
(let ((seq (let-vars-exps clauses)))
(let ((vars (let-vars seq))
(exps (let-exps seq))
(body (let-body seq)))
(cons (make-lambda vars body) exps)))
(let ((var (car clauses))
(bindings (cadr clauses))
(body (cddr clauses)))
(let ((vars (let-vars bindings))
(exps (let-exps bindings)))
(sequence->exp
(list 'define var (make-lambda vars body))
(cons var exps)))))))
(define sequence->exp (get 'sequence->exp))
(define make-lambda (get 'make-lambda))
(define (make-vars-exps vars exps)
(if (null? (cdr vars))
(list (list (car vars) (car exps)))
(cons (list (car vars) (car exps))
(make-vars-exps (cdr vars) (cdr exps)))))
;; 問題 4.7のlet*で使うために追加
(define (make-let vars exps body)
(list 'let
(make-vars-exps vars exps)
body))
(put 'make-let make-let)
(put 'let (lambda (exp env)
(let->combination exp))))
;; 問題 4.7
(define (install-let*-package)
(define (let*-clauses exp) (cdr exp))
(define (let*-vars-exps clauses) (car clauses))
(define (let*-vars seq)
(if (null? (cdr seq))
(list (caar seq))
(cons (caar seq)
(let*vars (cdr seq)))))
(define (let*-exps seq)
(if (null? (cdr seq))
(list (cadar seq))
(cons (cadar seq)
(let*-exps (cdr seq)))))
(define (let*-body clauses) (cdr clauses))
(define (let*->nested-lets exp)
(let ((clauses (let*-clauses exp)))
(let ((vars-exps (let*-vars-exps clauses))
(body (let*-body clauses)))
(let ((vars (let*-vars vars-exps))
(exps (let*-exps vars-exps)))
(expand vars exps body)))))
(define (expand vars exps body)
(if (null? (cdr vars))
(make-let vars exps body)
(make-let (list (car vars))
(list (car exps))
(expand (cdr vars)
(cdr exps)
body))))
(define make-let (get 'make-let))
(put 'let* (lambda (exp env)
(let*-nested-lets exp))))
;; 問題 4.9 反復構造
(define (install-while-package)
;; make-ifとmake-beginから導出
(define (eval-while exp env)
(make-if (while-predicate exp)
(make-begin (append (while-body exp)
(list (eval-while exp env))))
'()))
(define (while-predicate exp) (cadr exp))
(define (while-body exp) (caddr exp))
(define make-if (get 'make-if))
(define make-begin (get 'make-begin))
(put 'while eval-while))
;; 問題 4.10 (def <var> <val>)という構文を設計、実装してみる。
;; 意味は(define <var> <val>)と同じ
(define (install-def-package)
(define (eval-def exp env)
(def-variable! (def-variable exp)
(eval (def-value exp) env)
env)
'ok)
(define (def-variable exp)
(if (symbol? (cadr exp))
(cadr exp)
(caadr exp)))
(define (def-value exp)
(if (symbol? (cadr exp))
(caddr exp)
(make-lambda (cdadr exp)
(cddr exp))))
(define make-lambda (get 'make-lambda))
(put 'def eval-def))
(install-quoted-package)
(install-assignment-package)
(install-definition-package)
(install-if-package)
(install-lambda-package)
(install-begin-package)
(instll-cond-package)
(install-and-package)
(install-or-package)
(install-let-package)
(install-let*-package)
(install-while-package)
(install-def-package)
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./sample10.scm $
0 コメント:
コメントを投稿