diff options
| -rw-r--r-- | ps04_combinators_amb/analyze-amb.scm | 208 | ||||
| -rw-r--r-- | ps04_combinators_amb/analyze.scm | 120 | ||||
| -rw-r--r-- | ps04_combinators_amb/ghelper.scm | 102 | ||||
| -rw-r--r-- | ps04_combinators_amb/load-amb.scm | 14 | ||||
| -rw-r--r-- | ps04_combinators_amb/load-analyze.scm | 13 | ||||
| -rw-r--r-- | ps04_combinators_amb/multiple-dwelling.scm | 30 | ||||
| -rw-r--r-- | ps04_combinators_amb/ps.txt | 148 | ||||
| -rw-r--r-- | ps04_combinators_amb/repl-amb.scm | 80 | ||||
| -rw-r--r-- | ps04_combinators_amb/repl.scm | 48 | ||||
| -rw-r--r-- | ps04_combinators_amb/rtdata.scm | 88 | ||||
| -rw-r--r-- | ps04_combinators_amb/syntax.scm | 190 | ||||
| -rw-r--r-- | ps04_combinators_amb/utils.scm | 17 |
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) |