summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ps04_combinators_amb/analyze-amb.scm208
-rw-r--r--ps04_combinators_amb/analyze.scm120
-rw-r--r--ps04_combinators_amb/ghelper.scm102
-rw-r--r--ps04_combinators_amb/load-amb.scm14
-rw-r--r--ps04_combinators_amb/load-analyze.scm13
-rw-r--r--ps04_combinators_amb/multiple-dwelling.scm30
-rw-r--r--ps04_combinators_amb/ps.txt148
-rw-r--r--ps04_combinators_amb/repl-amb.scm80
-rw-r--r--ps04_combinators_amb/repl.scm48
-rw-r--r--ps04_combinators_amb/rtdata.scm88
-rw-r--r--ps04_combinators_amb/syntax.scm190
-rw-r--r--ps04_combinators_amb/utils.scm17
12 files changed, 1058 insertions, 0 deletions
diff --git a/ps04_combinators_amb/analyze-amb.scm b/ps04_combinators_amb/analyze-amb.scm
new file mode 100644
index 0000000..5d5ad56
--- /dev/null
+++ b/ps04_combinators_amb/analyze-amb.scm
@@ -0,0 +1,208 @@
+;;;; Analyzing interpreter with AMB.
+;;; Execution procedures take environment
+;;; and two continuations: SUCCEED and FAIL
+
+(define (ambeval exp env succeed fail)
+ ((analyze exp) env succeed fail))
+
+(define analyze
+ (make-generic-operator 1
+ (lambda (exp)
+ (cond ((application? exp) (analyze-application exp))
+ (else (error "Unknown expression type" exp))))))
+
+(define (analyze-self-evaluating exp)
+ (lambda (env succeed fail)
+ (succeed exp fail)))
+
+(defhandler analyze analyze-self-evaluating self-evaluating?)
+
+
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env succeed fail)
+ (succeed qval fail))))
+
+(defhandler analyze analyze-quoted quoted?)
+
+
+(define (analyze-variable exp)
+ (lambda (env succeed fail)
+ (succeed (lookup-variable-value exp env) fail)))
+
+(defhandler analyze analyze-variable variable?)
+
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze (lambda-body exp))))
+ (lambda (env succeed fail)
+ (succeed (make-compound-procedure vars bproc env)
+ fail))))
+
+(defhandler analyze analyze-lambda lambda?)
+
+
+(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 pred-fail)
+ (if (true? pred-value)
+ (cproc env succeed pred-fail)
+ (aproc env succeed pred-fail)))
+ fail))))
+
+(defhandler analyze analyze-if if?)
+
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env succeed fail)
+ (proc1 env
+ (lambda (proc1-value proc1-fail)
+ (proc2 env succeed proc1-fail))
+ fail)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (if (null? exps) (error "Empty sequence"))
+ (let ((procs (map analyze exps)))
+ (loop (car procs) (cdr procs))))
+
+(defhandler analyze
+ (lambda (exp)
+ (analyze-sequence (begin-actions exp)))
+ begin?)
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env succeed fail)
+ (fproc env
+ (lambda (proc proc-fail)
+ (get-args aprocs env
+ (lambda (args args-fail)
+ (execute-application proc
+ args
+ succeed
+ args-fail))
+ proc-fail))
+ fail))))
+
+(define (get-args aprocs env succeed fail)
+ (cond ((null? aprocs) (succeed '() fail))
+ ((null? (cdr aprocs))
+ ((car aprocs) env
+ (lambda (arg fail)
+ (succeed (list arg) fail))
+ fail))
+ (else
+ ((car aprocs) env
+ (lambda (arg fail)
+ (get-args (cdr aprocs) env
+ (lambda (args fail)
+ (succeed (cons arg args)
+ fail))
+ fail))
+ fail))))
+
+(define execute-application
+ (make-generic-operator 4
+ (lambda (proc args succeed fail)
+ (error "Unknown procedure type" proc))))
+
+(defhandler execute-application
+ (lambda (proc args succeed fail)
+ (succeed (apply-primitive-procedure proc args) fail))
+ strict-primitive-procedure?)
+
+(defhandler execute-application
+ (lambda (proc args succeed fail)
+ ((procedure-body proc)
+ (extend-environment (procedure-parameters proc)
+ args
+ (procedure-environment proc))
+ succeed
+ fail))
+ compound-procedure?)
+
+;;; There are two useful kinds of assignments in AMB
+;;; interpreters. Undoable assignments and permanent
+;;; assignments. The default is the undoable assignment.
+
+(define (analyze-undoable-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (new-val val-fail)
+ (let ((old-val (lookup-variable-value var env)))
+ (set-variable-value! var new-val env)
+ (succeed 'OK
+ (lambda ()
+ (set-variable-value! var old-val env)
+ (val-fail)))))
+ fail))))
+
+(defhandler analyze
+ analyze-undoable-assignment
+ assignment?)
+
+
+(define (analyze-permanent-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (new-val val-fail)
+ (set-variable-value! var new-val env)
+ (succeed 'OK fail))
+ fail))))
+
+(defhandler analyze
+ analyze-permanent-assignment
+ permanent-assignment?)
+
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env succeed fail)
+ (vproc env
+ (lambda (new-val val-fail)
+ (define-variable! var new-val env)
+ (succeed var val-fail))
+ fail))))
+
+(defhandler analyze analyze-definition definition?)
+
+
+;;; AMB, itself!
+
+(define (analyze-amb exp)
+ (let ((aprocs (map analyze (amb-alternatives exp))))
+ (lambda (env succeed fail)
+ (let loop ((alts aprocs))
+ (if (null? alts)
+ (fail)
+ ((car alts) env
+ succeed
+ (lambda ()
+ (loop (cdr alts)))))))))
+
+(defhandler analyze analyze-amb amb?)
+
+
+;;; Macros (definitions are in syntax.scm)
+
+(defhandler analyze
+ (lambda (exp)
+ (analyze (cond->if exp)))
+ cond?)
+
+(defhandler analyze
+ (lambda (exp)
+ (analyze (let->combination exp)))
+ let?)
diff --git a/ps04_combinators_amb/analyze.scm b/ps04_combinators_amb/analyze.scm
new file mode 100644
index 0000000..8f83b74
--- /dev/null
+++ b/ps04_combinators_amb/analyze.scm
@@ -0,0 +1,120 @@
+;;;; Separating analysis from execution.
+;;; Generic analysis, but not prepared for
+;;; extension to handle nonstrict operands.
+
+(define (eval exp env)
+ ((analyze exp) env))
+
+(define analyze
+ (make-generic-operator 1
+ (lambda (exp)
+ (cond ((application? exp)
+ (analyze-application exp))
+ (else
+ (error "Unknown expression type"
+ exp))))))
+
+(define (analyze-self-evaluating exp)
+ (lambda (env) exp))
+
+(defhandler analyze analyze-self-evaluating self-evaluating?)
+
+
+(define (analyze-quoted exp)
+ (let ((qval (text-of-quotation exp)))
+ (lambda (env) qval)))
+
+(defhandler analyze analyze-quoted quoted?)
+
+
+(define (analyze-variable exp)
+ (lambda (env) (lookup-variable-value exp env)))
+
+(defhandler analyze analyze-variable variable?)
+
+(define (analyze-if exp)
+ (let ((pproc (analyze (if-predicate exp)))
+ (cproc (analyze (if-consequent exp)))
+ (aproc (analyze (if-alternative exp))))
+ (lambda (env)
+ (if (true? (pproc env)) (cproc env) (aproc env)))))
+
+(defhandler analyze analyze-if if?)
+
+
+(define (analyze-lambda exp)
+ (let ((vars (lambda-parameters exp))
+ (bproc (analyze (lambda-body exp))))
+ (lambda (env)
+ (make-compound-procedure vars bproc env))))
+
+(defhandler analyze analyze-lambda lambda?)
+
+(define (analyze-application exp)
+ (let ((fproc (analyze (operator exp)))
+ (aprocs (map analyze (operands exp))))
+ (lambda (env)
+ (execute-application (fproc env)
+ (map (lambda (aproc) (aproc env))
+ aprocs)))))
+
+(define execute-application
+ (make-generic-operator 2
+ (lambda (proc args)
+ (error "Unknown procedure type" proc))))
+
+(defhandler execute-application
+ apply-primitive-procedure
+ strict-primitive-procedure?)
+
+(defhandler execute-application
+ (lambda (proc args)
+ ((procedure-body proc)
+ (extend-environment
+ (procedure-parameters proc)
+ args
+ (procedure-environment proc))))
+ compound-procedure?)
+
+(define (analyze-sequence exps)
+ (define (sequentially proc1 proc2)
+ (lambda (env) (proc1 env) (proc2 env)))
+ (define (loop first-proc rest-procs)
+ (if (null? rest-procs)
+ first-proc
+ (loop (sequentially first-proc (car rest-procs))
+ (cdr rest-procs))))
+ (if (null? exps) (error "Empty sequence"))
+ (let ((procs (map analyze exps)))
+ (loop (car procs) (cdr procs))))
+
+(defhandler analyze
+ (lambda (exp)
+ (analyze-sequence (begin-actions exp)))
+ begin?)
+
+
+(define (analyze-assignment exp)
+ (let ((var (assignment-variable exp))
+ (vproc (analyze (assignment-value exp))))
+ (lambda (env)
+ (set-variable-value! var (vproc env) env)
+ 'ok)))
+
+(defhandler analyze analyze-assignment assignment?)
+
+
+(define (analyze-definition exp)
+ (let ((var (definition-variable exp))
+ (vproc (analyze (definition-value exp))))
+ (lambda (env)
+ (define-variable! var (vproc env) env)
+ 'ok)))
+
+(defhandler analyze analyze-definition definition?)
+
+;;; Macros (definitions are in syntax.scm)
+
+(defhandler analyze (compose analyze cond->if) cond?)
+
+(defhandler analyze (compose analyze let->combination) let?)
diff --git a/ps04_combinators_amb/ghelper.scm b/ps04_combinators_amb/ghelper.scm
new file mode 100644
index 0000000..7b8613d
--- /dev/null
+++ b/ps04_combinators_amb/ghelper.scm
@@ -0,0 +1,102 @@
+;;;; Most General Generic-Operator Dispatch
+
+(declare (usual-integrations))
+
+;;; Generic-operator dispatch is implemented here by a discrimination
+;;; list, where the arguments passed to the operator are examined by
+;;; predicates that are supplied at the point of attachment of a
+;;; handler (by ASSIGN-OPERATION).
+
+;;; To be the correct branch all arguments must be accepted by
+;;; the branch predicates, so this makes it necessary to
+;;; backtrack to find another branch where the first argument
+;;; is accepted if the second argument is rejected. Here
+;;; backtracking is implemented by OR.
+
+(define (make-generic-operator arity default-operation)
+ (let ((record (make-operator-record arity)))
+
+ (define (operator . arguments)
+ (if (not (= (length arguments) arity))
+ (error:wrong-number-of-arguments operator arity arguments))
+ (let ((succeed
+ (lambda (handler)
+ (apply handler arguments))))
+ (let per-arg
+ ((tree (operator-record-tree record))
+ (args arguments)
+ (fail
+ (lambda ()
+ (error:no-applicable-methods operator arguments))))
+ (let per-pred ((tree tree) (fail fail))
+ (cond ((pair? tree)
+ (if ((caar tree) (car args))
+ (if (pair? (cdr args))
+ (per-arg (cdar tree)
+ (cdr args)
+ (lambda ()
+ (per-pred (cdr tree) fail)))
+ (succeed (cdar tree)))
+ (per-pred (cdr tree) fail)))
+ ((null? tree)
+ (fail))
+ (else
+ (succeed tree)))))))
+
+ (hash-table/put! *generic-operator-table* operator record)
+ (if default-operation
+ (assign-operation operator default-operation))
+ operator))
+
+(define *generic-operator-table*
+ (make-eq-hash-table))
+
+(define (make-operator-record arity) (cons arity '()))
+(define (operator-record-arity record) (car record))
+(define (operator-record-tree record) (cdr record))
+(define (set-operator-record-tree! record tree) (set-cdr! record tree))
+
+(define (assign-operation operator handler . argument-predicates)
+ (let ((record
+ (let ((record (hash-table/get *generic-operator-table* operator #f))
+ (arity (length argument-predicates)))
+ (if record
+ (begin
+ (if (not (<= arity (operator-record-arity record)))
+ (error "Incorrect operator arity:" operator))
+ record)
+ (let ((record (make-operator-record arity)))
+ (hash-table/put! *generic-operator-table* operator record)
+ record)))))
+ (set-operator-record-tree! record
+ (bind-in-tree argument-predicates
+ handler
+ (operator-record-tree record))))
+ operator)
+
+(define defhandler assign-operation)
+
+(define (bind-in-tree keys handler tree)
+ (let loop ((keys keys) (tree tree))
+ (if (pair? keys)
+ (let find-key ((tree* tree))
+ (if (pair? tree*)
+ (if (eq? (caar tree*) (car keys))
+ (begin
+ (set-cdr! (car tree*)
+ (loop (cdr keys) (cdar tree*)))
+ tree)
+ (find-key (cdr tree*)))
+ (cons (cons (car keys)
+ (loop (cdr keys) '()))
+ tree)))
+ (if (pair? tree)
+ (let ((p (last-pair tree)))
+ (if (not (null? (cdr p)))
+ (warn "Replacing a handler:" (cdr p) handler))
+ (set-cdr! p handler)
+ tree)
+ (begin
+ (if (not (null? tree))
+ (warn "Replacing top-level handler:" tree handler))
+ handler))))) \ No newline at end of file
diff --git a/ps04_combinators_amb/load-amb.scm b/ps04_combinators_amb/load-amb.scm
new file mode 100644
index 0000000..6f3d1a8
--- /dev/null
+++ b/ps04_combinators_amb/load-amb.scm
@@ -0,0 +1,14 @@
+(load "utils" user-initial-environment)
+(load "ghelper" user-initial-environment)
+(load "syntax" user-initial-environment)
+(load "rtdata" user-initial-environment)
+
+
+(define generic-evaluation-environment
+ (extend-top-level-environment user-initial-environment))
+
+(load "analyze-amb" generic-evaluation-environment)
+(load "repl-amb" generic-evaluation-environment)
+
+
+(ge generic-evaluation-environment) \ No newline at end of file
diff --git a/ps04_combinators_amb/load-analyze.scm b/ps04_combinators_amb/load-analyze.scm
new file mode 100644
index 0000000..02e447e
--- /dev/null
+++ b/ps04_combinators_amb/load-analyze.scm
@@ -0,0 +1,13 @@
+(load "utils" user-initial-environment)
+(load "ghelper" user-initial-environment)
+(load "syntax" user-initial-environment)
+(load "rtdata" user-initial-environment)
+
+
+(define generic-evaluation-environment
+ (extend-top-level-environment user-initial-environment))
+
+(load "analyze" generic-evaluation-environment)
+(load "repl" generic-evaluation-environment)
+
+(ge generic-evaluation-environment) \ No newline at end of file
diff --git a/ps04_combinators_amb/multiple-dwelling.scm b/ps04_combinators_amb/multiple-dwelling.scm
new file mode 100644
index 0000000..4ab0311
--- /dev/null
+++ b/ps04_combinators_amb/multiple-dwelling.scm
@@ -0,0 +1,30 @@
+
+(define (require p)
+ (if (not p) (amb)))
+
+(define (distinct l)
+ (cond ((null? l) true)
+ ((null? (cdr l)) true)
+ ((member (car l) (cdr l)) false)
+ (else (distinct (cdr l)))))
+
+(define (multiple-dwelling)
+ (let ((baker (amb 1 2 3 4 5))
+ (cooper (amb 1 2 3 4 5))
+ (fletcher (amb 1 2 3 4 5))
+ (miller (amb 1 2 3 4 5))
+ (smith (amb 1 2 3 4 5)))
+ (require
+ (distinct (list baker cooper fletcher miller smith)))
+ (require (not (= baker 5)))
+ (require (not (= cooper 1)))
+ (require (not (= fletcher 5)))
+ (require (not (= fletcher 1)))
+ (require (> miller cooper))
+ (require (not (= (abs (- smith fletcher)) 1)))
+ (require (not (= (abs (- fletcher cooper)) 1)))
+ (list (list 'baker baker)
+ (list 'cooper cooper)
+ (list 'fletcher fletcher)
+ (list 'miller miller)
+ (list 'smith smith))))
diff --git a/ps04_combinators_amb/ps.txt b/ps04_combinators_amb/ps.txt
new file mode 100644
index 0000000..56df0d8
--- /dev/null
+++ b/ps04_combinators_amb/ps.txt
@@ -0,0 +1,148 @@
+
+ MASSACHVSETTS INSTITVTE OF TECHNOLOGY
+ Department of Electrical Engineering and Computer Science
+
+ 6.945 Spring 2009
+ Problem Set 4
+
+ Issued: Wed. 25 Feb. 2009 Due: Wed. 4 Mar. 2009
+
+Reading:
+ SICP, From Chapter 4: section 4.1.7--4.2 (from PS03)
+ section 4.3; (pp. 412--437)
+
+Code: utils.scm, ghelper.scm, syntax.scm, rtdata.scm,
+ load-analyze.scm, analyze.scm, repl.scm
+ load-amb.scm, analyze-amb.scm repl-amb.scm
+ multiple-dwelling.scm
+
+
+ Heavy Evaluator Hacking
+
+In this problem set we build interpreters in a different direction.
+We start with the essential EVAL/APPLY interpreter, written as an
+analyzer of the syntax into a compiler of compositions of execution
+procedures -- a small combinator language. We will warm up by making
+modifications to this evaluator.
+
+Next, we will change the evaluator to include AMB expressions. To add
+AMB, the execution procedures will all have a different shape: in
+addition to the environment, each will take two "continuation
+procedures" SUCCEED and FAIL. In general, when a computation comes up
+with a value it will invoke SUCCEED with the proposed value and a
+complaint department which, if invoked, will try to produce an
+alternate value. If a computation cannot come up with a value, it
+will invoke the complaint department passed to it in the FAIL
+continuation.
+
+An important lesson to be learned here is how to use continuation
+procedures to partially escape the expression structure of the
+language. By construction, a functional expression has a unique
+value. However, in the AMB system an expression may be ambiguous as
+to its value... Think about how we arrange that to make sense!
+
+---------------------------------------------------------------------
+
+ Separating Syntactic Analysis from Execution
+ (Compiling to Combinators)
+
+It is important to read SICP section 4.1.7 carefully here. When you
+load "load-analyze.scm" you will get an evaluator similar to the one
+described in this section.
+
+
+-------------
+Problem 4.1: Warmup
+
+It is often valuable to have procedures that can take an indefinite
+number of arguments. The addition and multiplication procedures in
+Scheme are examples of such procedures. Traditionally, a user may
+specify such a procedure in a definition by making the bound-variable
+specification of a lambda expression a symbol rather than a list of
+formal parameters. That symbol is expected to be bound to the list of
+arguments supplied. For example, to make a procedure that takes
+several arguments and returns a list of the squares of the arguments
+supplied, one may write:
+
+(lambda x (map square x))
+
+or
+
+(define (ss . x) (map square x))
+
+and then
+
+(ss 1 2 3 4) ==> (1 4 9 16)
+
+Modify the analyzing interpreter to allow this construction.
+
+Hint: you do not need to change the code involving DEFINE or LAMBDA
+in syntax.scm! This is entirely a change in analyze.scm
+
+Demonstrate that your modification allows this kind of procedure, and
+that it does not cause other troubles.
+-------------
+
+-------------
+Problem 4.2: Infix notation
+
+Many people like infix notation for small arithmetic expressions. It
+is not hard to write a special form, (INFIX <infix-string>), that
+takes a character string, parses it as an infix expression with the
+usual precedence rules, and reduces it to Lisp. Note that to do this
+you really don't have to delve into the combinator target mechanism of
+the evaluator, since this can be accomplished as a "macro" in the same
+way that COND and LET are implemented (see syntax.scm).
+
+So, for example, we should be able to write the program:
+
+(define (quadratic a b c)
+ (let ((discriminant (infix "b**2-4*a*c")))
+ (infix "(-b+sqrt(discriminant))/(2*a)")))
+
+Hint: Do not try to parse numbers! That is hard -- let Scheme do it
+for you: use string->number (see MIT Scheme documentation). Just
+pass the substring that specifies the number to string->number to get
+the numerical value.
+
+Write the INFIX special form, install it in the evaluator, and
+demonstrate that it works.
+
+Please! Unless you have lots of time to burn, do not write a complete
+infix parser for some entire language, like Python (easy) or Java
+(hard)! We just want parsing of simple arithmetic expressions.
+-------------
+
+
+---------------------------------------------------------------------
+
+ AMB and Nondeterministic Programming
+
+Now comes the real fun part of this problem set! Please read section
+4.3 of SICP carefully before starting this part. This interpreter
+requires a change in the interface structure of the combinators that
+code compiles into, so it is quite different. Of course, our system
+differs from the one in SICP in that it is implemented with generic
+extension capability. The loader for the interpreter extended for AMB
+is "load-analyze.scm".
+
+-------------
+Problem 4.3: Warmup: Programming with AMB
+
+Run the multiple-dwelling program (to get a feeling for how to use the
+system).
+
+Do exercises 4.38, 4.39, and 4.40 (p. 419) from SICP.
+
+Note: we supply the multiple-dwelling.scm program so you need not type
+it in.
+-------------
+
+-------------
+Problem 4.4:
+
+Modify the AMB interpreter to record and report the number of
+alternatives examined in exploring a search space. What is this
+number for the simple multiple-dwelling program? For your best
+improvement of it from your work in exercise 4.40, above.
+-------------
diff --git a/ps04_combinators_amb/repl-amb.scm b/ps04_combinators_amb/repl-amb.scm
new file mode 100644
index 0000000..c7b6ccb
--- /dev/null
+++ b/ps04_combinators_amb/repl-amb.scm
@@ -0,0 +1,80 @@
+(declare (usual-integrations write write-line pp eval))
+
+(define write
+ (make-generic-operator 1
+ (access write user-initial-environment)))
+
+(define write-line
+ (make-generic-operator 1
+ (access write-line user-initial-environment)))
+
+(define pp
+ (make-generic-operator 1
+ (access pp user-initial-environment)))
+
+(define (procedure-printable-representation procedure)
+ `(compound-procedure
+ ,(procedure-parameters procedure)
+ ,(procedure-body procedure)
+ <procedure-environment>))
+
+(defhandler write
+ (compose write procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler write-line
+ (compose write-line procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler pp
+ (compose pp procedure-printable-representation)
+ compound-procedure?)
+
+
+(define (read) (prompt-for-command-expression "eval> "))
+
+(define the-global-environment)
+
+
+;;; Initialization and driver loop
+
+(define (evaluator exp succeed fail)
+ ((analyze exp)
+ the-global-environment
+ succeed
+ fail))
+
+(define input-prompt ";;; Amb-Eval input:\n")
+
+(define output-prompt "\n;;; Amb-Eval value:\n")
+
+(define (init)
+ (set! the-global-environment
+ (extend-environment '() '() the-empty-environment))
+ (driver-loop))
+
+(define (driver-loop)
+ (define (internal-loop try-again)
+ (let ((input
+ (prompt-for-command-expression input-prompt)))
+ (if (eq? input 'try-again)
+ (try-again)
+ (begin
+ (newline)
+ (display ";;; Starting a new problem ")
+ (evaluator
+ input
+ (lambda (val next-alternative)
+ (display output-prompt)
+ (pp val)
+ (internal-loop next-alternative))
+ (lambda ()
+ (display ";;; There are no more values of ")
+ (pp input)
+ (driver-loop)))))))
+ (internal-loop
+ (lambda ()
+ (display ";;; There is no current problem")
+ (driver-loop))))
+
+(define go driver-loop)
diff --git a/ps04_combinators_amb/repl.scm b/ps04_combinators_amb/repl.scm
new file mode 100644
index 0000000..b8ff8b7
--- /dev/null
+++ b/ps04_combinators_amb/repl.scm
@@ -0,0 +1,48 @@
+(declare (usual-integrations write write-line pp eval))
+
+(define write
+ (make-generic-operator 1
+ (access write user-initial-environment)))
+
+(define write-line
+ (make-generic-operator 1
+ (access write-line user-initial-environment)))
+
+(define pp
+ (make-generic-operator 1
+ (access pp user-initial-environment)))
+
+(define (procedure-printable-representation procedure)
+ `(compound-procedure
+ ,(procedure-parameters procedure)
+ ,(procedure-body procedure)
+ <procedure-environment>))
+
+(defhandler write
+ (compose write procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler write-line
+ (compose write-line procedure-printable-representation)
+ compound-procedure?)
+
+(defhandler pp
+ (compose pp procedure-printable-representation)
+ compound-procedure?)
+
+
+(define (read) (prompt-for-command-expression "eval> "))
+
+(define the-global-environment)
+
+(define (init)
+ (set! the-global-environment
+ (extend-environment '() '() the-empty-environment))
+ (repl))
+
+(define (repl)
+ (let ((input (read)))
+ (write-line (eval input the-global-environment))
+ (repl)))
+
+(define go repl)
diff --git a/ps04_combinators_amb/rtdata.scm b/ps04_combinators_amb/rtdata.scm
new file mode 100644
index 0000000..dad3d7a
--- /dev/null
+++ b/ps04_combinators_amb/rtdata.scm
@@ -0,0 +1,88 @@
+;;; -*- Mode:Scheme -*-
+
+(declare (usual-integrations))
+
+(define the-unspecified-value (list 'the-unspecified-value))
+
+(define (true? x)
+ (if x true false))
+
+(define (false? x)
+ (if x false true))
+
+;;; Primitive procedures are inherited from Scheme.
+
+(define strict-primitive-procedure? procedure?)
+(define apply-primitive-procedure apply)
+
+
+;;; Compound procedures
+
+(define (make-compound-procedure vars bproc env)
+ (vector 'compound-procedure vars bproc env))
+
+(define (compound-procedure? obj)
+ (and (vector? obj)
+ (eq? (vector-ref obj 0) 'compound-procedure)))
+
+(define (procedure-parameters p) (vector-ref p 1))
+(define (procedure-body p) (vector-ref p 2))
+(define (procedure-environment p) (vector-ref p 3))
+
+;;; An ENVIRONMENT is a chain of FRAMES, made of vectors.
+
+(define (extend-environment variables values base-environment)
+ (if (fix:= (length variables) (length values))
+ (vector variables values base-environment)
+ (if (fix:< (length variables) (length values))
+ (error "Too many arguments supplied" variables values)
+ (error "Too few arguments supplied" variables values))))
+
+(define (environment-variables env) (vector-ref env 0))
+(define (environment-values env) (vector-ref env 1))
+(define (environment-parent env) (vector-ref env 2))
+
+(define the-empty-environment '())
+
+(define (lookup-variable-value var env)
+ (let plp ((env env))
+ (if (eq? env the-empty-environment)
+ (lookup-scheme-value var)
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars) (plp (vector-ref env 2)))
+ ((eq? var (car vars)) (car vals))
+ (else (scan (cdr vars) (cdr vals))))))))
+
+;;; Extension to make underlying Scheme values available to interpreter
+
+(define (lookup-scheme-value var)
+ (lexical-reference generic-evaluation-environment var))
+
+(define (define-variable! var val env)
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- DEFINE" var) ;should not happen.
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars)
+ (vector-set! env 0 (cons var (vector-ref env 0)))
+ (vector-set! env 1 (cons val (vector-ref env 1))))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else
+ (scan (cdr vars) (cdr vals)))))))
+
+(define (set-variable-value! var val env)
+ (let plp ((env env))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- SET!" var)
+ (let scan
+ ((vars (vector-ref env 0))
+ (vals (vector-ref env 1)))
+ (cond ((null? vars) (plp (vector-ref env 2)))
+ ((eq? var (car vars)) (set-car! vals val))
+ (else (scan (cdr vars) (cdr vals))))))))
+
+
diff --git a/ps04_combinators_amb/syntax.scm b/ps04_combinators_amb/syntax.scm
new file mode 100644
index 0000000..40ba784
--- /dev/null
+++ b/ps04_combinators_amb/syntax.scm
@@ -0,0 +1,190 @@
+;;; -*- Mode:Scheme -*-
+
+(declare (usual-integrations))
+
+;;; Self-evaluating entities
+
+(define (self-evaluating? exp)
+ (or (number? exp)
+ (eq? exp #t)
+ (eq? exp #f)
+ (string? exp))) ; Our prompt (viz., "EVAL==> ") is a string.
+
+;;; Variables
+
+(define (variable? exp) (symbol? exp))
+
+(define (same-variable? var1 var2) (eq? var1 var2)) ;; Nice abstraction
+
+;;; Special forms (in general)
+
+(define (tagged-list? exp tag)
+ (and (pair? exp)
+ (eq? (car exp) tag)))
+
+;;; Quotations
+
+(define (quoted? exp) (tagged-list? exp 'quote))
+
+(define (text-of-quotation quot) (cadr quot))
+
+;;; Assignment--- SET!
+
+(define (assignment? exp) (tagged-list? exp 'set!))
+(define (permanent-assignment? exp) (tagged-list? exp 'set!!))
+
+(define (assignment-variable assn) (cadr assn))
+(define (assignment-value assn) (caddr assn))
+
+;;; Definitions
+
+(define (definition? exp) (tagged-list? exp 'define))
+
+(define (definition-variable defn)
+ (if (variable? (cadr defn)) ;; (DEFINE foo ...)
+ (cadr defn)
+ (caadr defn))) ;; (DEFINE (foo ...) ...)
+
+(define (definition-value defn)
+ (if (variable? (cadr defn)) ;; (DEFINE foo ...)
+ (caddr defn)
+ (cons 'lambda ;; (DEFINE (foo p...) b...)
+ (cons (cdadr defn) ;; = (DEFINE foo
+ (cddr defn))))) ;; (LAMBDA (p...) b...))
+
+;;; LAMBDA expressions
+
+(define (lambda? exp) (tagged-list? exp 'lambda))
+(define (lambda-parameters lambda-exp) (cadr lambda-exp))
+(define (lambda-body lambda-exp)
+ (let ((full-body (cddr lambda-exp)))
+ (sequence->begin full-body)))
+
+
+(define declaration? pair?)
+
+(define (parameter-name var-decl)
+ (if (pair? var-decl)
+ (car var-decl)
+ var-decl))
+
+(define (lazy? var-decl)
+ (and (pair? var-decl)
+ (memq 'lazy (cdr var-decl))
+ (not (memq 'memo (cdr var-decl)))))
+
+(define (lazy-memo? var-decl)
+ (and (pair? var-decl)
+ (memq 'lazy (cdr var-decl))
+ (memq 'memo (cdr var-decl))))
+
+(define (sequence->begin seq)
+ (cond ((null? seq) seq)
+ ((null? (cdr seq)) (car seq))
+ ((begin? (car seq)) seq)
+ (else (make-begin seq))))
+
+(define (make-begin exp) (cons 'begin exp))
+
+;;; If conditionals
+
+(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)
+ 'the-unspecified-value))
+
+(define (make-if pred conseq alternative)
+ (list 'IF pred conseq alternative))
+
+
+;;; COND Conditionals
+
+(define (cond? exp) (tagged-list? exp 'cond))
+
+(define (clauses cndl) (cdr cndl))
+(define (no-clauses? clauses) (null? clauses))
+(define (first-clause clauses) (car clauses))
+(define (rest-clauses clauses) (cdr clauses))
+(define (else-clause? clause) (eq? (predicate clause) 'else))
+
+(define (predicate clause) (car clause))
+
+(define (actions clause)
+ (sequence->begin (cdr clause)))
+
+(define (cond->if cond-exp)
+ (define (expand clauses)
+ (cond ((no-clauses? clauses)
+ (list 'error "COND: no values matched"))
+ ((else-clause? (car clauses))
+ (if (no-clauses? (cdr clauses))
+ (actions (car clauses))
+ (error "else clause isn't last -- INTERP" exp)))
+ (else
+ (make-if (predicate (car clauses))
+ (actions (car clauses))
+ (expand (cdr clauses))))))
+ (expand (clauses cond-exp)))
+
+
+;;; BEGIN expressions (a.k.a. sequences)
+
+(define (begin? exp) (tagged-list? exp 'begin))
+(define (begin-actions begin-exp) (cdr begin-exp))
+
+(define (last-exp? seq) (null? (cdr seq)))
+(define (first-exp seq) (car seq))
+(define (rest-exps seq) (cdr seq))
+(define no-more-exps? null?) ; for non-tail-recursive vers.
+
+;;; LET expressions
+
+(define (let? exp) (tagged-list? exp 'let))
+(define (let-bound-variables let-exp)
+ (map car (cadr let-exp)))
+(define (let-values let-exp) (map cadr (cadr let-exp)))
+(define (let-body let-exp) (sequence->begin (cddr let-exp)))
+(define (let->combination let-exp)
+ (let ((names (let-bound-variables let-exp))
+ (values (let-values let-exp))
+ (body (let-body let-exp)))
+ (cons (list 'LAMBDA names body)
+ values)))
+
+;;; Procedure applications -- NO-ARGS? and LAST-OPERAND? added
+
+(define (application? exp)
+ (pair? exp))
+
+(define (no-args? exp) ;; Added for tail recursion
+ (and (pair? exp)
+ (null? (cdr exp))))
+
+(define (args-application? exp) ;; Changed from 5.2.1
+ (and (pair? exp)
+ (not (null? (cdr exp)))))
+
+
+(define (operator app) (car app))
+(define (operands app) (cdr app))
+
+(define (last-operand? args) ;; Added for tail recursion
+ (null? (cdr args)))
+
+(define (no-operands? args) (null? args))
+(define (first-operand args) (car args))
+(define (rest-operands args) (cdr args))
+
+;;; Another special form that will be needed later.
+
+(define (amb? exp)
+ (and (pair? exp) (eq? (car exp) 'amb)))
+
+(define (amb-alternatives exp) (cdr exp))
+
diff --git a/ps04_combinators_amb/utils.scm b/ps04_combinators_amb/utils.scm
new file mode 100644
index 0000000..cac9281
--- /dev/null
+++ b/ps04_combinators_amb/utils.scm
@@ -0,0 +1,17 @@
+(declare (usual-integrations))
+
+
+(define (identity x) x)
+
+(define (any? x) #t)
+
+
+(define ((compose f g) x) (f (g x)))
+
+
+;;; This is to keep the Scheme printer from going into an infinite
+;;; loop if you try to print a circular data structure, such as an
+;;; environment
+
+(set! *unparser-list-depth-limit* 10)
+(set! *unparser-list-breadth-limit* 10)