計算機プログラムの構造と解釈[第2版]
(翔泳社)
ハロルド エイブルソン (著) ジュリー サスマン (著)
ジェラルド・ジェイ サスマン (著)
Harold Abelson (原著) Julie Sussman (原著)
Gerald Jay Sussman (原著) 和田 英一 (翻訳)
開発環境
- OS X Yosemite - 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.3(Schemeの変形 - 非決定性計算)、4.3.3(amb評価機の実装)、実行手続きと継続、問題 4.51.を解いてみる。
その他参考書籍
- Instructor's Manual to Accompany Structure & Interpretation of Computer Programs
- プログラミングGauche (Kahuaプロジェクト (著), 川合 史朗 (監修), オライリージャパン)
問題 4.51.
コード(BBEdit, Emacs)
amb_evaluator.scm
#!/usr/bin/env gosh ;; -*- coding: utf-8 -*- (load "./amb_syntax_analyzer.scm") (define input-prompt ";;; Amb-Eval input:") (define output-prompt ";;; Amb-Eval value:") (define (prompt-for-input string) (newline) (newline) (print string)) (define (announce-output string) (newline) (print string)) (define (user-print object) (if (compound-procedure? object) (display (list 'compound-procedure (procedure-parameters object) (procedure-body object) '<procedure-env>)) (display object))) (define (driver-loop) (define (internal-loop try-again) (prompt-for-input input-prompt) (let ((input (read))) (if (eq? input 'try-again) (try-again) (begin (newline) (display ";;; Starting a new problem ") (ambeval input the-global-environment (lambda (val next-alternative) (announce-output output-prompt) (user-print val) (internal-loop next-alternative)) (lambda () (announce-output ";;; There are no more values of") (user-print input) (driver-loop))))))) (internal-loop (lambda () (newline) (display ";;; There is no current problem") (driver-loop)))) (driver-loop)
amb_expressions.scm
#!/usr/bin/env gosh ;; -*- coding: utf-8 -*- (define true #t) (define false #f) (define apply-in-underlying-scheme apply) (define (list-of-values exps env) (if (no-operands? exps) '() (cons (eval (first-operand exps) env) (list-of-values (rest-operands exps) env)))) (define (self-evaluation? exp) (if (or (number? exp) (string? exp)) #t #f)) (define (variable? exp) (symbol? exp)) (define (tagged-list? exp tag) (if (pair? exp) (eq? (car exp) tag) #f)) (define (quoted? exp) (tagged-list? exp 'quote)) (define (text-of-quotation exp) (cadr exp)) (define (assignment? exp) (tagged-list? exp 'set!)) (define (assignment-variable exp) (cadr exp)) (define (assignment-value exp) (caddr exp)) (define (permanent-assignment? exp) (tagged-list? exp 'permanent-set!)) (define (permanent-assignment-variable exp) (cadr exp)) (define (permanent-assignment-value exp) (caddr exp)) (define (definition? exp) (tagged-list? exp 'define)) (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 (if? exp) (tagged-list? exp 'if)) (define (if-predicate exp) (cadr exp)) (define (if-consequent exp) (caddr exp)) (define (if-alternative exp) (if (not (null? (cdddr exp))) (cadddr exp) 'false)) (define (make-if predicate consequent alternative) (list 'if predicate consequent alternative)) (define (amb? exp) (tagged-list? exp 'amb)) (define (amb-choices exp) (cdr exp)) (define (lambda? exp) (tagged-list? exp 'lambda)) (define (lambda-parameters exp) (cadr exp)) (define (lambda-body exp) (cddr exp)) (define (make-lambda parameters body) (cons 'lambda (cons parameters body))) (define (let? exp) (tagged-list? exp 'let)) (define (let-clauses exp) (cdr exp)) (define (let-vars-exps clauses) (car clauses)) (define (let->combination exp) (let ((clauses (let-clauses exp))) (let ((vars-exps (let-vars-exps clauses))) (cons (make-lambda (map car vars-exps) (cdr clauses)) (map cadr vars-exps))))) (define (begin? exp) (tagged-list? exp 'begin)) (define (begin-actions exp) (cdr exp)) (define (last-exp? seq) (null? (cdr seq))) (define (first-exp seq) (car seq)) (define (rest-exps 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)) (define (cond? exp) (tagged-list? exp 'cond)) (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) (sequence->exp (cond-actions first)) (expand-clauses rest)))))) (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)) (define (true? x) (not (eq? x false))) (define (false? x) (eq? x false)) (define (make-procedure parameters body env) (list 'procedure parameters body env)) (define (compound-procedure? p) (tagged-list? p 'procedure)) (define (procedure-parameters p) (cadr p)) (define (procedure-body p) (caddr p)) (define (procedure-environment p) (cadddr p)) (define (enclosing-environment env) (cdr env)) (define (first-frame env) (car env)) (define the-empty-environment '()) (define (make-frame variables values) (cons variables values)) (define (frame-variables frame) (car frame)) (define (frame-values frame) (cdr frame)) (define (add-binding-to-frame! var val frame) (set-car! frame (cons var (car frame))) (set-cdr! frame (cons val (cdr frame)))) (define (extend-environment vars vals base-env) (if (= (length vars) (length vals)) (cons (make-frame vars vals) base-env) (if (< (length vars) (length vals)) (error "Too many arguments supplied" var vals) (error "Too few arguments supplied" var vals)))) (define (lookup-variable-value var env) (define (env-loop env) (define (scan vars vals) (cond ((null? vars) (env-loop (enclosing-environment env))) ((eq? var (car vars)) (car vals)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) (error "Unbound variable" var) (let ((frame (first-frame env))) (scan (frame-variables frame) (frame-values frame))))) (env-loop env)) (define (set-variable-value! var val env) (define (env-loop env) (define (scan vars vals) (cond ((null? vars) (env-loop (enclosing-environment env))) ((eq? var (car vars)) (set-car! vals val)) (else (scan (cdr vars) (cdr vals))))) (if (eq? env the-empty-environment) (error "Unbound variable -- SET!" var) (let ((frame (first-frame env))) (scan (frame-variables frame) (frame-values frame))))) (env-loop env)) (define (define-variable! var val env) (let ((frame (first-frame env))) (define (scan vars vals) (cond ((null? vars) (add-binding-to-frame! var val frame)) ((eq? var (car vars)) (set-car! vals val)) (else (scan (cdr vars) (cdr vals))))) (scan (frame-variables frame) (frame-values frame)))) (define primitive-procedures (list (list 'car car) (list 'cdr cdr) (list 'cons cons) (list 'null? null?) (list 'exit exit) (list '= =) (list '+ +) (list '- -) (list '* *) (list 'list list) (list 'not not) (list 'eq? eq?) ;; 基本手続き )) (define (primitive-procedure-names) (map car primitive-procedures)) (define (primitive-procedure-objects) (map (lambda (proc) (list 'primitive (cadr proc))) primitive-procedures)) (define (apply-primitive-procedure proc args) (apply-in-underlying-scheme (primitive-implementation proc) args)) (define (setup-environment) (let ((initial-env (extend-environment (primitive-procedure-names) (primitive-procedure-objects) the-empty-environment))) (define-variable! 'true true initial-env) (define-variable! 'false false initial-env) initial-env)) (define the-global-environment (setup-environment)) (define (primitive-procedure? proc) (tagged-list? proc 'primitive)) (define (primitive-implementation proc) (cadr proc))
ramb_syntax_analyzer.scm
#!/usr/bin/env gosh ;; -*- coding: utf-8 -*- (load "./amb_expressions.scm") (define (analyze exp) (cond ((self-evaluation? exp) (analyze-self-evaluating exp)) ((quoted? exp) (analyze-quoted exp)) ((variable? exp) (analyze-variable exp)) ((assignment? exp) (analyze-assignment exp)) ;; 問題4.51 ((permanent-assignment? exp) (analyze-permanent-assignment exp)) ((definition? exp) (analyze-definition exp )) ((if? exp) (analyze-if exp)) ((amb? exp) (analyze-amb exp)) ((lambda? exp) (analyze-lambda exp)) ((let? exp) (analyze (let->combination exp))) ((begin? exp) (analyze-sequence (begin-actions exp))) ((cond? exp) (analyze (cond->if exp))) ((application? exp) (analyze-application exp)) (else (error "Unknown expression type -- ANALYZE" exp)))) (define (ambeval exp env succeed fail) ((analyze exp) env succeed fail)) (define (analyze-self-evaluating exp) (lambda (env succeed fail) (succeed exp fail))) (define (analyze-quoted exp) (let ((qval (text-of-quotation exp))) (lambda (env succeed fail) (succeed qval fail)))) (define (analyze-variable exp) (lambda (env succeed fail) (succeed (lookup-variable-value exp env) fail))) (define (analyze-lambda exp) (let ((vars (lambda-parameters exp)) (bproc (analyze-sequence (lambda-body exp)))) (lambda (env succeed fail) (succeed (make-procedure vars bproc env) fail)))) (define (analyze-if exp) (let ((pproc (analyze (if-predicate exp))) (cproc (analyze (if-consequent exp))) (aproc (analyze (if-alternative exp)))) (lambda (env succeed fail) (pproc env (lambda (pred-value fail2) (if (true? pred-value) (cproc env succeed fail2) (aproc env succeed fail2))) fail)))) (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 exps))) (if (null? procs) (error "Empty sequence -- ANALYZE")) (loop (car procs) (cdr procs)))) (define (analyze-definition exp) (let ((var (definition-variable exp)) (vproc (analyze (definition-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (define-variable! var val env) (succeed 'ok fail2)) fail)))) (define (analyze-assignment exp) (let ((var (assignment-variable exp)) (vproc (analyze (assignment-value exp)))) (lambda (env succeed fail) (vproc env (lambda (val fail2) (let ((old-value (lookup-variable-value var env))) (set-variable-value! var val env) (succeed 'ok (lambda () (set-variable-value! var old-value env) (fail2))))) fail)))) (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)))) (define (analyze-application exp) (let ((pproc (analyze (operator exp))) (aprocs (map analyze (operands exp)))) (lambda (env succeed fail) (pproc env (lambda (proc fail2) (get-args aprocs env (lambda (args fail3) (execute-application proc args succeed fail3)) fail2)) fail)))) (define (get-args aprocs env succeed fail) (if (null? aprocs) (succeed '() fail) ((car aprocs) env (lambda (arg fail2) (get-args (cdr aprocs) env (lambda (args fail3) (succeed (cons arg args) fail3)) fail2)) fail))) (define (execute-application proc args succeed fail) (cond ((primitive-procedure? proc) (succeed (apply-primitive-procedure proc args) fail)) ((compound-procedure? proc) ((procedure-body proc) (extend-environment (procedure-parameters proc) args (procedure-environment proc)) succeed fail)) (else (error "Unknown procedure type -- EXECUTE-APPLICATION" proc)))) (define (analyze-amb exp) (let ((cprocs (map analyze (amb-choices exp)))) (lambda (env succeed fail) (define (try-next choices) (if (null? choices) (fail) ((car choices) env succeed (lambda () (try-next (cdr choices)))))) (try-next cprocs))))
入出力結果(Terminal(gosh), REPL(Read, Eval, Print, Loop))
$ ./amb_evaluator.scm ;;; Amb-Eval input: (define (require p) (if (not p) (amb))) ;;; Starting a new problem ;;; Amb-Eval value: ok ;;; Amb-Eval input: (define (an-element-of-items items) (require (not (null? items))) (amb (car items) (an-element-of-items (cdr items)))) ;;; Starting a new problem ;;; Amb-Eval value: ok ;;; Amb-Eval input: (define count 0) ;;; Starting a new problem ;;; Amb-Eval value: ok ;;; Amb-Eval input: (let ((x (an-element-of-items '(a b c))) (y (an-element-of-items '(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: try-again ;;; Amb-Eval value: (b a 4) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b c 6) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c a 7) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c b 8) ;;; Amb-Eval input: try-again ;;; There are no more values of (let ((x (an-element-of-items '(a b c))) (y (an-element-of-items '(a b c)))) (permanent-set! count (+ count 1)) (require (not (eq? x y))) (list x y count)) ;;; Amb-Eval input: (define count 0) ;;; Starting a new problem ;;; Amb-Eval value: ok ;;; Amb-Eval input: (let ((x (an-element-of-items '(a b c))) (y (an-element-of-items '(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) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b a 1) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (b c 1) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c a 1) ;;; Amb-Eval input: try-again ;;; Amb-Eval value: (c b 1) ;;; Amb-Eval input: try-again ;;; There are no more values of (let ((x (an-element-of-items '(a b c))) (y (an-element-of-items '(a b c)))) (set! count (+ count 1)) (require (not (eq? x y))) (list x y count)) ;;; Amb-Eval input: (exit) ;;; Starting a new problem $
0 コメント:
コメントを投稿