diff --git a/#371.scm# b/#371.scm# deleted file mode 100644 index 7680b17..0000000 --- a/#371.scm# +++ /dev/null @@ -1,29 +0,0 @@ -(define (weight-sr pair) - (+ (cube (car pair)) - (cube (cadr pair)))) - -(define (cube x) - (* x x x)) - -(define (equal-stream-next s) - (let ((next (stream-car (stream-cdr s)))) - (= (stream-car s) next))) - -(define (pairs-cube s1 s2) - (weighted-pairs s1 s2 weight-sr)) - -(define stream-pairs-cube - (pairs-cube integers integers)) - -(define pairs-sr - (let ((equal-num 0)) - (define (equal-stream-formal pair) - (let ((val (weight-sr pair))) - (if (= val equal-num) - (begin (set! equal-num 0) - val) - (begin (set! equal-num val) - #f)))) - (define (stream-filter-value s) - (let ((exam-pair (stream-car s))) - (if ))))) diff --git a/116.scm b/116.scm old mode 100644 new mode 100755 diff --git a/129.scm b/129.scm old mode 100644 new mode 100755 diff --git a/130.scm b/130.scm old mode 100644 new mode 100755 diff --git a/131.scm b/131.scm old mode 100644 new mode 100755 diff --git a/132.scm b/132.scm old mode 100644 new mode 100755 diff --git a/133.scm b/133.scm old mode 100644 new mode 100755 diff --git a/217.scm b/217.scm old mode 100644 new mode 100755 diff --git a/218.scm b/218.scm old mode 100644 new mode 100755 diff --git a/220.scm b/220.scm old mode 100644 new mode 100755 diff --git a/221.scm b/221.scm old mode 100644 new mode 100755 diff --git a/223.scm b/223.scm old mode 100644 new mode 100755 diff --git a/224.scm b/224.scm old mode 100644 new mode 100755 diff --git a/227.scm b/227.scm old mode 100644 new mode 100755 diff --git a/228.scm b/228.scm old mode 100644 new mode 100755 diff --git a/229.scm b/229.scm old mode 100644 new mode 100755 diff --git a/230.scm b/230.scm old mode 100644 new mode 100755 diff --git a/232.scm b/232.scm old mode 100644 new mode 100755 diff --git a/233.scm b/233.scm old mode 100644 new mode 100755 diff --git a/234.scm b/234.scm old mode 100644 new mode 100755 diff --git a/235.scm b/235.scm old mode 100644 new mode 100755 diff --git a/236.scm b/236.scm old mode 100644 new mode 100755 diff --git a/237.scm b/237.scm old mode 100644 new mode 100755 diff --git a/238.scm b/238.scm old mode 100644 new mode 100755 diff --git a/239.scm b/239.scm old mode 100644 new mode 100755 diff --git a/240.scm b/240.scm old mode 100644 new mode 100755 diff --git a/241.scm b/241.scm old mode 100644 new mode 100755 diff --git a/242.scm b/242.scm old mode 100644 new mode 100755 diff --git a/256.scm b/256.scm old mode 100644 new mode 100755 diff --git a/257.scm b/257.scm old mode 100644 new mode 100755 diff --git a/258.scm b/258.scm old mode 100644 new mode 100755 diff --git a/259.scm b/259.scm old mode 100644 new mode 100755 diff --git a/260.scm b/260.scm old mode 100644 new mode 100755 diff --git a/261.scm b/261.scm old mode 100644 new mode 100755 diff --git a/262.scm b/262.scm old mode 100644 new mode 100755 diff --git a/263.scm b/263.scm old mode 100644 new mode 100755 diff --git a/264.scm b/264.scm old mode 100644 new mode 100755 diff --git a/265.scm b/265.scm old mode 100644 new mode 100755 diff --git a/266.scm b/266.scm old mode 100644 new mode 100755 diff --git a/267.scm b/267.scm old mode 100644 new mode 100755 diff --git a/268.scm b/268.scm old mode 100644 new mode 100755 diff --git a/269.scm b/269.scm old mode 100644 new mode 100755 diff --git a/270.scm b/270.scm old mode 100644 new mode 100755 diff --git a/273.scm b/273.scm old mode 100644 new mode 100755 diff --git a/275.scm b/275.scm old mode 100644 new mode 100755 diff --git a/277.scm b/277.scm old mode 100644 new mode 100755 diff --git a/278.scm b/278.scm old mode 100644 new mode 100755 diff --git a/279.scm b/279.scm old mode 100644 new mode 100755 diff --git a/280.scm b/280.scm old mode 100644 new mode 100755 diff --git a/281.scm b/281.scm old mode 100644 new mode 100755 diff --git a/282.scm b/282.scm old mode 100644 new mode 100755 diff --git a/31.scm b/31.scm old mode 100644 new mode 100755 diff --git a/312.scm b/312.scm old mode 100644 new mode 100755 diff --git a/313.scm b/313.scm old mode 100644 new mode 100755 diff --git a/314.scm b/314.scm old mode 100644 new mode 100755 diff --git a/316.scm b/316.scm old mode 100644 new mode 100755 diff --git a/317.scm b/317.scm old mode 100644 new mode 100755 diff --git a/318.scm b/318.scm old mode 100644 new mode 100755 diff --git a/319.scm b/319.scm old mode 100644 new mode 100755 diff --git a/32.scm b/32.scm old mode 100644 new mode 100755 diff --git a/321.scm b/321.scm old mode 100644 new mode 100755 diff --git a/322.scm b/322.scm old mode 100644 new mode 100755 diff --git a/323.scm b/323.scm old mode 100644 new mode 100755 diff --git a/324.scm b/324.scm old mode 100644 new mode 100755 diff --git a/325.scm b/325.scm old mode 100644 new mode 100755 diff --git a/326.scm b/326.scm old mode 100644 new mode 100755 diff --git a/326_compare.scm b/326_compare.scm old mode 100644 new mode 100755 diff --git a/327.scm b/327.scm old mode 100644 new mode 100755 diff --git a/328.scm b/328.scm old mode 100644 new mode 100755 diff --git a/329.scm b/329.scm old mode 100644 new mode 100755 diff --git a/33.scm b/33.scm old mode 100644 new mode 100755 diff --git a/330.scm b/330.scm old mode 100644 new mode 100755 diff --git a/333.scm b/333.scm old mode 100644 new mode 100755 diff --git a/334.scm b/334.scm old mode 100644 new mode 100755 diff --git a/337.scm b/337.scm old mode 100644 new mode 100755 diff --git a/34.scm b/34.scm old mode 100644 new mode 100755 diff --git a/347.scm b/347.scm old mode 100644 new mode 100755 diff --git a/348.scm b/348.scm old mode 100644 new mode 100755 diff --git a/35.scm b/35.scm old mode 100644 new mode 100755 diff --git a/350.scm b/350.scm old mode 100644 new mode 100755 diff --git a/351.scm b/351.scm old mode 100644 new mode 100755 diff --git a/352.scm b/352.scm old mode 100644 new mode 100755 diff --git a/353.scm b/353.scm old mode 100644 new mode 100755 diff --git a/354.scm b/354.scm old mode 100644 new mode 100755 diff --git a/355.scm b/355.scm old mode 100644 new mode 100755 diff --git a/356.scm b/356.scm old mode 100644 new mode 100755 diff --git a/358.scm b/358.scm old mode 100644 new mode 100755 diff --git a/359.scm b/359.scm old mode 100644 new mode 100755 diff --git a/36.scm b/36.scm old mode 100644 new mode 100755 diff --git a/360.scm b/360.scm old mode 100644 new mode 100755 diff --git a/361.scm b/361.scm old mode 100644 new mode 100755 diff --git a/362.scm b/362.scm old mode 100644 new mode 100755 diff --git a/363.scm b/363.scm old mode 100644 new mode 100755 diff --git a/364.scm b/364.scm old mode 100644 new mode 100755 diff --git a/365.scm b/365.scm old mode 100644 new mode 100755 diff --git a/369.scm b/369.scm old mode 100644 new mode 100755 diff --git a/37.scm b/37.scm old mode 100644 new mode 100755 diff --git a/370.scm b/370.scm old mode 100644 new mode 100755 index 5020ef7..2364799 --- a/370.scm +++ b/370.scm @@ -20,6 +20,7 @@ (stream-cdr s2) weight))))))) +;; i <= j, and assume the first member of s1 and s2 is equal (define (weighted-pairs s1 s2 weight) (cons-stream (list (stream-car s1) (stream-car s2)) (merge-weighted (stream-map (lambda (x) (list (stream-car s1) x)) diff --git a/371.scm b/371.scm old mode 100644 new mode 100755 index f2992b2..3db2826 --- a/371.scm +++ b/371.scm @@ -1,3 +1,7 @@ +(load "354.scm") +(load "370.scm") +(load "ch351.scm") + (define (weight-sr pair) (+ (cube (car pair)) (cube (cadr pair)))) @@ -26,3 +30,7 @@ #f)))) (stream-filter equal-stream-formal stream-pairs-cube))) + +(define Ramanujan + (stream-map (lambda (pair) (weight-sr pair)) + pairs-sr)) diff --git a/372.scm b/372.scm new file mode 100755 index 0000000..870f7ad --- /dev/null +++ b/372.scm @@ -0,0 +1,18 @@ +(load "354.scm") +(load "370.scm") +(load "ch351.scm") + +(define (square x) (* x x)) +(define (sum-square x) (+ (square (car x)) (square (cadr x)))) +(define (squaresn s) + (define (stream-cadr s) (stream-car (stream-cdr s))) + (define (stream-caddr s) (stream-cadr (stream-cdr s))) + (let ((scar (stream-car s)) + (scadr (stream-cadr s)) + (scaddr (stream-caddr s))) + (if (= (sum-square scar) (sum-square scadr) (sum-square scaddr)) + (cons-stream (list (sum-square scar) scar scadr scaddr) + (squaresn (stream-cdr (stream-cdr (stream-cdr s))))) + (squaresn (stream-cdr s))))) +(define square-numbers + (squaresn (weighted-pairs integers integers sum-square))) diff --git a/373.scm b/373.scm old mode 100644 new mode 100755 index 3ec4ee0..22a53b3 --- a/373.scm +++ b/373.scm @@ -1,4 +1,4 @@ -(define (integral integrand initial-value dt) +o(define (integral integrand initial-value dt) (define int (cons-stream initial-value (add-streams (scale-stream integrand dt) diff --git a/38.scm b/38.scm old mode 100644 new mode 100755 diff --git a/41.scm b/41.scm new file mode 100755 index 0000000..2da1b24 --- /dev/null +++ b/41.scm @@ -0,0 +1,13 @@ +(define (list-of-values exps env) + (if (no-operands? exps) + '() + (let ((first (eval (first-operand exps) env))) + (cons first + (list-of-values (rest-operands exps) env))))) + +(define (list-of-values exps env) + (if (no-operands? exps) + '() + (let ((rest (list-of-values (rest-operands exps) env))) + (cons (eval (first-operand exps) env) + rest)))) diff --git a/411.scm b/411.scm new file mode 100755 index 0000000..e9ace95 --- /dev/null +++ b/411.scm @@ -0,0 +1,7 @@ +(define (make-frame variables values) + (map cons variables values)) +(define (frame-variables frame) (map car frame)) +(define (frame-values frame) (map cdr frame)) +(define (add-binding-to-frame! var val frame) + (cons (cons var val) + frame)) diff --git a/412.scm b/412.scm new file mode 100755 index 0000000..c78e91f --- /dev/null +++ b/412.scm @@ -0,0 +1,32 @@ +(define (lookup-variable-in-environment var env) + (if (eq? env the-empty-environment) + false + (let ((result (lookup-variable-in-frame var (first-frame env)))) + (if (true? result) + result + (lookup-variable-in-frame var (enclosing-environment env)))))) + +(define (lookup-variable-in-frame var frame) + (define (scan-in-frame vars vals) + (cond ((null? vars) false) + ((eq? var (car vars)) vals) + (else (scan-in-frame (cdr vars) (cdr vals))))) + (scan-in-frame (frame-variables frame) (frame-values frame))) + +(define (lookup-variable-value var env) + (let ((pos (lookup-variable-in-environment var env))) + (if pos + (car pos) + (error "Unbound variable" var)))) +(define (set-variable-value! var val env) + (let ((pos (lookup-variable-in-environment var env))) + (if pos + (set-car! vals val) + (error "Unbound variable --SET!" var)))) + +(define (define-variable! var val env) + (let ((first (first-frame env)) + (pos (lookup-variable-in-frame var first))) + (if pos + (set-car! vals val) + (add-binding-to-frame! var val first)))) diff --git a/416.scm b/416.scm new file mode 100755 index 0000000..63b1474 --- /dev/null +++ b/416.scm @@ -0,0 +1,436 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or exp env)) + ((let? exp) (eval (let->combination exp) env)) + ((let*? exp) (eval (let*->nested-lets 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (map car parameters)) +(define (let-exps parameters) + (map cadr parameters)) + +(define (make-procedure-define var parameters body) + (list 'define (cons var parameters) body)) +(define (let->combination exp) + (if (or (pair? (cadr exp)) (null? (cadr exp))) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters))) + (let ((arguments (cdr exp))) + (let ((var (car arguments)) + (parameters (map car (cadr arguments))) + (values (map cadr (cadr arguments)))) + (make-begin (list + (make-procedure-define var + parameters + (caddr arguments)) + (cons var values))))))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (list 'let parameters body)) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(define (scan-out-defines procedure-body) + (define (is-define? bodys) + (and (pair? (car bodys)) (eq? (caar bodys) 'define))) + (define (get-all-define-bodys bodys) + (cond ((null? bodys) '()) + ((is-define? bodys) (cons (cdar bodys) (get-all-define-bodys (cdr bodys)))) + (else (get-all-define-bodys (cdr bodys))))) + (define (get-other-bodys bodys) + (cond ((null? bodys) '()) + ((is-define? bodys) (get-other-bodys (cdr bodys))) + (else (cons (cdar bodys) + (get-other-bodys (cdr bodys)))))) + (let ((define-bodys (get-all-define-bodys procedure-body))) + (if (null? define-bodys) + procedure-body + (let ((define-vars (map car define-bodys)) + (define-vals (map cdr define-bodys)) + (last-bodys (get-other-bodys procedure-body))) + (make-let (map (lambda (x) (cons x '*unassigned*)) define-vars) + (append + (map (lambda (x y) (list 'set! x y)) define-vars define-vals) + last-bodys)))))) + +(define (make-procedure parameters body env) + (list 'procedure parameters + (scan-out-defines 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" vars vals) + (error "Too few arguments supplied" vars 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)) + (if (eq? (car vals) '*unassigned*) + (error "This variable is unassigned" var) + (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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) diff --git a/42.scm b/42.scm new file mode 100755 index 0000000..7f001b4 --- /dev/null +++ b/42.scm @@ -0,0 +1,25 @@ +(define (application? exp) (tagged-list? exp 'call)) +(define (operator exp) (cadr exp)) +(define (operands exp) (cddr exp)) +(define (no-operands? ops) (null? ops)) +(define (first-operand ops) (car ops)) +(define (second-operand ops) (cdr ops)) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((application? exp) + (apply (eval (operator exp) env) + (list-of-values (operands exp) env))) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + (else + (error "Unknown expression type -- EVAL" exp)))) diff --git a/420.scm b/420.scm new file mode 100755 index 0000000..55f1786 --- /dev/null +++ b/420.scm @@ -0,0 +1,453 @@ +(define (letrec->let exp) + (let ((parameters (cadr exp)) + (body (cddr exp))) + (let ((vars (map car parameters)) + (exps (map cadr parameters))) + (make-let (map (lambda (x) (list x ''*unassigned*)) vars) + (make-begin + (append (map (lambda (x y) (list 'set! x y)) vars exps) + body)))))) + +(define (letrec? exp) + (tagged-list? exp 'letrec)) + +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or exp env)) + ((let? exp) (eval (let->combination exp) env)) + ((let*? exp) (eval (let*->nested-lets exp) env)) + ((letrec? exp) (eval (letrec->let 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (map car parameters)) +(define (let-exps parameters) + (map cadr parameters)) + +(define (make-procedure-define var parameters body) + (list 'define (cons var parameters) body)) +(define (let->combination exp) + (if (or (pair? (cadr exp)) (null? (cadr exp))) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters))) + (let ((arguments (cdr exp))) + (let ((var (car arguments)) + (parameters (map car (cadr arguments))) + (values (map cadr (cadr arguments)))) + (make-begin (list + (make-procedure-define var + parameters + (caddr arguments)) + (cons var values))))))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (list 'let parameters body)) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(define (scan-out-defines procedure-body) + (define (is-define? bodys) + (and (pair? (car bodys)) (eq? (caar bodys) 'define))) + (define (get-all-define-bodys bodys) + (cond ((null? bodys) '()) + ((is-define? bodys) (cons (cdar bodys) (get-all-define-bodys (cdr bodys)))) + (else (get-all-define-bodys (cdr bodys))))) + (define (get-other-bodys bodys) + (cond ((null? bodys) '()) + ((is-define? bodys) (get-other-bodys (cdr bodys))) + (else + (cons (car bodys) + (get-other-bodys (cdr bodys)))))) + (let ((define-bodys (get-all-define-bodys procedure-body))) + (if (null? define-bodys) + procedure-body + (let ((define-vars (map car define-bodys)) + (define-vals (map cadr define-bodys)) + (last-bodys (get-other-bodys procedure-body))) + (cons 'let (cons + (map (lambda (x) (list x ''*unassigned*)) define-vars) + (append + (map (lambda (x y) (list 'set! x y)) define-vars define-vals) + last-bodys))))))) + +(define (make-procedure parameters body env) + (list 'procedure parameters + (scan-out-defines 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" vars vals) + (error "Too few arguments supplied" vars 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)) + (if (eq? (car vals) '*unassigned*) + (error "This variable is unassigned" var) + (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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) + +(letrec ((fact (lambda (n) (if (= n 1) 1 (* n (fact (- n 1))))))) (fact 10)) diff --git a/421.scm b/421.scm new file mode 100755 index 0000000..3bbb683 --- /dev/null +++ b/421.scm @@ -0,0 +1,15 @@ +(define (f x) + ((lambda (even? odd?) + (even? even? odd? x)) + (lambda (ev? od? n) ;function of even + (if (= n 0) true (od? ev? od? (- n 1)))) + (lambda (ev? od? n) ;function of odd + (if (= n 0) false (ev? ev? od? (- n 1)))))) + +(define (fib n) + ((lambda (fib-iter) + (fib-iter fib-iter n)) + (lambda (fib-iter k) + (if (or (= k 0) (= k 1)) + 1 + (+ (fib-iter fib-iter (- k 1)) (fib-iter fib-iter (- k 2))))))) diff --git a/422.scm b/422.scm new file mode 100755 index 0000000..ca6511a --- /dev/null +++ b/422.scm @@ -0,0 +1,105 @@ +(define (analyze exp) + (cond ((self-evaluating? exp) (analyze-self-evaluating exp)) + ((variable? exp) (analyze-variable exp)) + ((quoted? exp) (analyze-quoted exp)) + ((assignment? exp) (analyze-assignment exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (COND->IF exp))) + ((let? exp) (analyze (LET->combination exp))) + ((application? exp) (analyze-application exp)) + (else + (error "Unknown expression type -- ANALYZE" exp)))) + + +(define (analyze-self-evaluating exp) + (lambda (env) exp)) + + +(define (analyze-quoted exp) + (let ((qval (text-of-quotation exp))) + (lambda (env) qval))) + + +(define (analyze-variable exp) + (lambda (env) + (lookup-variable-value exp env))) + + +(define (analyze-assignment exp) + (let ((var (assignment-variable exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env) + (set-variable-value! var (vproc env) env)))) + + +(define (analyze-definition exp) + (let ((var (definition-variable exp)) + (vproc (analyze (definition-value exp)))) + (lambda (env) + (define-variable! var (vproc env) env)))) + + +(define (analyze-lambda exp) + (let ((vars (lambda-parameters exp)) + (bproc (analyze-sequence (lambda-body exp)))) + (lambda (env) + (make-procedure vars bproc env)))) + + +(define (analyze-if exp) + (let ((pproc (analyze (if-predicate exp))) + (cproc (analyze (if-consequent exp))) + (aproc (analyze (if-alternative exp)))) + (lambda (env) + (if (force-it (pproc env)) + (cproc env) + (aproc env))))) + + +(define (analyze-sequence exps) + (define (sequentially a b) + (lambda (env) (force-it (a env)) (b env))) + (let ((procs (map analyze exps))) + (define (loop first rest) + (if (null? rest) + first + (loop (sequentially first (car rest)) + (cdr rest)))) + (if (null? procs) + (error + "BEGIN requires subexpressions -- ANALYZE" exps)) + (loop (car procs) (cdr procs)))) + + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operands exp)))) + (lambda (env) + (exapply (force-it (fproc env)) aprocs env)))) + + +(define (exapply proc aprocs env) + (cond ((primitive-procedure? proc) + (apply-primitive-procedure + proc + (force-all-args aprocs env))) + ((compound-procedure? proc) + (let ((params (procedure-parameters proc))) + ((procedure-body proc) + (extend-environment (parameter-names params) + (process-arg-procs params aprocs env) + (procedure-environment proc))))) + (else + (error "Unknown procedure type -- EXAPPLY" + proc)))) + + +(define (start-analyze) + (set! current-evaluator (lambda (exp env) ((analyze exp) env))) + (set! current-prompt "AEVAL=> ") + (set! current-value-label ";;A-value: ") + (init-env) + (eval-loop)) diff --git a/43.scm b/43.scm new file mode 100755 index 0000000..882e046 --- /dev/null +++ b/43.scm @@ -0,0 +1,159 @@ +(load "make-table.scm") +(define (apply-generic op . args) + (let ((type-tags (map type-tag args))) + (let ((proc (get op type-tags))) + (if proc + (apply proc (map contents args)) + (error + "No method for these types -- APPLY-GENERIC" + (list op type-tags)))))) + +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + (else + ((get 'IsMem (expression-type exp)) + (get 'GetContent (expression-content exp) env))))) + +(define (expression-type exp) (car exp)) +(define (expression-content exp) (cadr exp)) + +(define (install-eval-variable) + (define (variable? exp) + (symbol? exp)) + ;; interferce + (put 'IsMem 'variable + (lambda (exp) (variable? exp)))) + (put 'GetContent 'variable + (lookup-variable-value exp env)) +(install-eval-variable) + +(define (install-eval-quoted) + (define (quoted? exp) + (tagged-list? exp 'quote)) + (define (text-of-quotation exp) + (cadr exp)) + ;; interfece + (put 'IsMem 'quoted (quoted? exp)) + (put 'GetContent 'quoted (text-of-quotation exp))) +(install-eval-quoted) + +(define (install-eval-assignment) + (define (assignment? exp) + (tagged-list? exp 'assignment)) + (define (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + (define (assignment-value exp) (caddr exp)) + (define (assignment-variable exp) (cadr exp)) + + (put 'IsMem 'assignment (assignment? exp)) + (put 'GetContent 'assignment (eval-assignment exp env))) +(install-eval-assignment) + +(define (install-eval-definition) + (define (definition? exp) + (tagged-list? exp 'define)) + (define (definition-value exp) + (if (symbol? (cadr exp)) + (caddr exp) + (make-lambda (cdadr exp) + (cddr exp)))) + (define (definition-variable exp) + (if (symbol? (cadr exp)) + (cadr exp) + (caddr exp))) + (define (eval-definition exp env) + (define-variabl! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + + (put 'IsMem 'definition (definition? exp)) + (put 'GetContent 'definition (eval-definition exp env))) +(install-eval-definition) + +(define (install-eval-lambda) + (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))) + + (put 'IsMem 'lambda (lambda? exp)) + (put 'GetContent 'lambda (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + (put 'make-lambda 'lambda (make-lambda parameters body))) +(install-eval-lambda) +(define make-lambda (get 'make-lambda 'lambda)) + +(define (install-eval-if) + (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 (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + + (put 'IsMem 'if (if? exp)) + (put 'GetContent 'if (eval-if exp env))) +(install-eval-if) + +(define (install-eval-begin) + (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 exp) (cons 'begin seq)) + (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)))) + + (put 'IsMem 'begin (begin? exp)) + (put 'GetContent 'begin (eval-sequence exp env)) + (put 'sequence->exp 'begin (sequence->exp seq))) +(install-eval-begin) +(define (sequence->exp seq) (get 'sequence->exp 'begin)) + +(define (install-eval-application) + (define (application? exp) (tagged-list? exp 'call)) + (define (operator exp) (cadr exp)) + (define (operands exp) (cddr exp)) + (define (no-operands? ops) (null? ops)) + (define (first-operands? ops) (car ops)) + (define (rest-operands ops) (cdr ops)) + (define (apply procedure arguments) + (cons ((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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + + (put 'IsMem 'application (application? exp)) + (put 'GetContent 'application (apply (eval (operator exp) env) + (list-of-values exp env)))) +(install-eval-application) diff --git a/433.scm b/433.scm new file mode 100755 index 0000000..038104c --- /dev/null +++ b/433.scm @@ -0,0 +1,480 @@ +(define (make-procedure-define var parameters body) + (list 'define (cons var parameters) body)) +(define (let->combination exp) + (if (pair? (cadr exp)) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters))) + (let ((arguments (cdr exp))) + (let ((var (car arguments)) + (parameters (map car (cadr arguments))) + (values (map cadr (cadr arguments)))) + (make-begin (list + (make-procedure-define var + parameters + (caddr arguments)) + (cons var values))))))) + +(define apply-in-underlying-scheme apply) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (if (null? parameters) + '() + (cons (caar parameters) + (let-variables (cdr parameters))))) +(define (let-exps parameters) + (if (null? parameters) + '() + (cons (cadar parameters) + (let-exps (cdr parameters))))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (cons 'let + (cons parameters body))) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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-name) + (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 (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + + +;; lazy part +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((application? exp) ; clause from book + (apply (actual-value (operator exp) env) + (operands exp) + env)) + (else + (error "Unknown expression type -- EVAL" exp)))) + +(define (actual-value exp env) + (force-it (eval exp env))) + +(define (apply procedure arguments env) + (cond ((primitive-procedure? procedure) + (apply-primitive-procedure + procedure + (list-of-arg-values arguments env))) ; changed + ((compound-procedure? procedure) + (eval-sequence + (procedure-body procedure) + (extend-environment + (procedure-parameters procedure) + (list-of-delayed-args arguments env) ; changed + (procedure-environment procedure)))) + (else + (error + "Unknown procedure type -- APPLY" procedure)))) + +(define (list-of-arg-values exps env) + (if (no-operands? exps) + '() + (cons (actual-value (first-operand exps) env) + (list-of-arg-values (rest-operands exps) + env)))) + +(define (list-of-delayed-args exps env) + (if (no-operands? exps) + '() + (cons (delay-it (first-operand exps) env) + (list-of-delayed-args (rest-operands exps) + env)))) + +(define (eval-if exp env) + (if (true? (actual-value (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(define input-prompt ";;; L-Eval input:") +(define output-prompt ";;; L-Eval value:") + +(define (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output + (actual-value input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + + +;;; Representing thunks + +;; non-memoizing version of force-it + +(define (force-it obj) + (if (thunk? obj) + (actual-value (thunk-exp obj) (thunk-env obj)) + obj)) + +;; thunks + +(define (delay-it exp env) + (list 'thunk exp env)) + +(define (thunk? obj) + (tagged-list? obj 'thunk)) + +(define (thunk-exp thunk) (cadr thunk)) +(define (thunk-env thunk) (caddr thunk)) + +;; "thunk" that has been forced and is storing its (memoized) value +(define (evaluated-thunk? obj) + (tagged-list? obj 'evaluated-thunk)) + +(define (thunk-value evaluated-thunk) (cadr evaluated-thunk)) + + +;; memoizing version of force-it + +(define (force-it obj) + (cond ((thunk? obj) + (let ((result (actual-value + (thunk-exp obj) + (thunk-env obj)))) + (set-car! obj 'evaluated-thunk) + (set-car! (cdr obj) result) ; replace exp with its value + (set-cdr! (cdr obj) '()) ; forget unneeded env + result)) + ((evaluated-thunk? obj) + (thunk-value obj)) + (else obj))) + + +;; A longer list of primitives -- suitable for running everything in 4.2 +;; Overrides the list in ch4-mceval.scm + +'LAZY-EVALUATOR-LOADED + +(driver-loop) diff --git a/44.scm b/44.scm new file mode 100755 index 0000000..7542976 --- /dev/null +++ b/44.scm @@ -0,0 +1,350 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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 true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) diff --git a/45.scm b/45.scm new file mode 100755 index 0000000..7361a9a --- /dev/null +++ b/45.scm @@ -0,0 +1,361 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) diff --git a/451.scm b/451.scm new file mode 100755 index 0000000..40bef4b --- /dev/null +++ b/451.scm @@ -0,0 +1,508 @@ +(define apply-in-underlying-scheme apply) +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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) + (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 true #t) +(define false #f) +(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" vars vals) + (error "Too few arguments supplied" vars 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 'list list) + (list 'memq memq) + (list 'member member) + (list 'not not) + (list '+ +) + (list '- -) + (list '* *) + (list '= =) + (list '> >) + (list '>= >=) + (list 'abs abs) + (list 'remainder remainder) + (list 'integer? integer?) + (list 'sqrt sqrt) + (list 'eq? eq?) +;; more primitives + )) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + + +;;;Code from SECTION 4.3.3, modified as needed to run it + +(define (amb? exp) (tagged-list? exp 'amb)) +(define (amb-choices exp) (cdr exp)) + +;; analyze from 4.1.6, with clause from 4.3.3 added +;; and also support for Let +(define (analyze exp) + (cond ((self-evaluating? exp) + (analyze-self-evaluating exp)) + ((quoted? exp) (analyze-quoted exp)) + ((variable? exp) (analyze-variable exp)) + ((assignment? exp) (analyze-assignment exp)) + ((permanent-assignment? exp) (analyze-permanent-assignment exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (cond->if exp))) + ((let? exp) (analyze (let->combination exp))) ;** + ((amb? exp) (analyze-amb exp)) ;** + ((application? exp) (analyze-application exp)) + (else + (error "Unknown expression type -- ANALYZE" exp)))) + +(define (permanent-assignment? exp) (tagged-list? exp 'permanent-set!)) +(define (analyze-permanent-assignment exp) + (let ((var (assignment-variable exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env succeed fail) + (vproc env (lambda (val fail2) + (set-variable-value! var val env) + (succeed 'ok fail2)) + fail)))) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +;;;Simple expressions + +(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)))) + +;;;Conditionals and sequences + +(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 + ;; success continuation for evaluating the predicate + ;; to obtain pred-value + (lambda (pred-value fail2) + (if (true? pred-value) + (cproc env succeed fail2) + (aproc env succeed fail2))) + ;; failure continuation for evaluating the predicate + fail)))) + +(define (analyze-sequence exps) + (define (sequentially a b) + (lambda (env succeed fail) + (a env + ;; success continuation for calling a + (lambda (a-value fail2) + (b env succeed fail2)) + ;; failure continuation for calling a + 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)))) + +;;;Definitions and assignments + +(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) ; *1* + (let ((old-value + (lookup-variable-value var env))) + (set-variable-value! var val env) + (succeed 'ok + (lambda () ; *2* + (set-variable-value! var + old-value + env) + (fail2))))) + fail)))) + +;;;Procedure applications + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operands exp)))) + (lambda (env succeed fail) + (fproc 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 + ;; success continuation for this aproc + (lambda (arg fail2) + (get-args (cdr aprocs) + env + ;; success continuation for recursive + ;; call to get-args + (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)))) + +;;;amb expressions + +(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)))) + +;;;Driver loop + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (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 + ;; ambeval success + (lambda (val next-alternative) + (announce-output output-prompt) + (user-print val) + (internal-loop next-alternative)) + ;; ambeval failure + (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)))) + + + +;;; Support for Let (as noted in footnote 56, p.428) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-bindings exp) (cadr exp)) +(define (let-body exp) (cddr exp)) + +(define (let-var binding) (car binding)) +(define (let-val binding) (cadr binding)) + +(define (make-combination operator operands) (cons operator operands)) + +(define (let->combination exp) + ;;make-combination defined in earlier exercise + (let ((bindings (let-bindings exp))) + (make-combination (make-lambda (map let-var bindings) + (let-body exp)) + (map let-val bindings)))) + + + +;; A longer list of primitives -- suitable for running everything in 4.3 +;; Overrides the list in ch4-mceval.scm +;; Has Not to support Require; various stuff for code in text (including +;; support for Prime?); integer? and sqrt for exercise code; +;; eq? for ex. solution + + + + +'AMB-EVALUATOR-LOADED diff --git a/452.scm b/452.scm new file mode 100755 index 0000000..9aed81e --- /dev/null +++ b/452.scm @@ -0,0 +1,520 @@ +(define apply-in-underlying-scheme apply) +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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) + (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 true #t) +(define false #f) +(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" vars vals) + (error "Too few arguments supplied" vars 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 'list list) + (list 'memq memq) + (list 'member member) + (list 'not not) + (list '+ +) + (list '- -) + (list '* *) + (list '= =) + (list '> >) + (list '>= >=) + (list 'abs abs) + (list 'remainder remainder) + (list 'integer? integer?) + (list 'sqrt sqrt) + (list 'eq? eq?) +;; more primitives + )) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + + +;;;Code from SECTION 4.3.3, modified as needed to run it + +(define (amb? exp) (tagged-list? exp 'amb)) +(define (amb-choices exp) (cdr exp)) + +;; analyze from 4.1.6, with clause from 4.3.3 added +;; and also support for Let +(define (analyze exp) + (cond ((self-evaluating? exp) + (analyze-self-evaluating exp)) + ((quoted? exp) (analyze-quoted exp)) + ((variable? exp) (analyze-variable exp)) + ((assignment? exp) (analyze-assignment exp)) + ((permanent-assignment? exp) (analyze-permanent-assignment exp)) + ((if-fail? exp) (analyze-if-fail exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (cond->if exp))) + ((let? exp) (analyze (let->combination exp))) ;** + ((amb? exp) (analyze-amb exp)) ;** + ((application? exp) (analyze-application exp)) + (else + (error "Unknown expression type -- ANALYZE" exp)))) + +(define (permanent-assignment? exp) (tagged-list? exp 'permanent-set!)) +(define (analyze-permanent-assignment exp) + (let ((var (assignment-variable exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env succeed fail) + (vproc env (lambda (val fail2) + (set-variable-value! var val env) + (succeed 'ok fail2)) + fail)))) + +(define (if-fail? exp) (tagged-list? exp 'if-fail)) +(define (analyze-if-fail exp) + (let ((first-exp (analyze (cadr exp))) + (second-exp (analyze (caddr exp)))) + (lambda (env succeed fail) + (first-exp env + (lambda (value fail1) + (succeed value fail1)) + (lambda () + (second-exp env succeed fail)))))) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +;;;Simple expressions + +(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)))) + +;;;Conditionals and sequences + +(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 + ;; success continuation for evaluating the predicate + ;; to obtain pred-value + (lambda (pred-value fail2) + (if (true? pred-value) + (cproc env succeed fail2) + (aproc env succeed fail2))) + ;; failure continuation for evaluating the predicate + fail)))) + +(define (analyze-sequence exps) + (define (sequentially a b) + (lambda (env succeed fail) + (a env + ;; success continuation for calling a + (lambda (a-value fail2) + (b env succeed fail2)) + ;; failure continuation for calling a + 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)))) + +;;;Definitions and assignments + +(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) ; *1* + (let ((old-value + (lookup-variable-value var env))) + (set-variable-value! var val env) + (succeed 'ok + (lambda () ; *2* + (set-variable-value! var + old-value + env) + (fail2))))) + fail)))) + +;;;Procedure applications + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operands exp)))) + (lambda (env succeed fail) + (fproc 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 + ;; success continuation for this aproc + (lambda (arg fail2) + (get-args (cdr aprocs) + env + ;; success continuation for recursive + ;; call to get-args + (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)))) + +;;;amb expressions + +(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)))) + +;;;Driver loop + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (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 + ;; ambeval success + (lambda (val next-alternative) + (announce-output output-prompt) + (user-print val) + (internal-loop next-alternative)) + ;; ambeval failure + (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)))) + + + +;;; Support for Let (as noted in footnote 56, p.428) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-bindings exp) (cadr exp)) +(define (let-body exp) (cddr exp)) + +(define (let-var binding) (car binding)) +(define (let-val binding) (cadr binding)) + +(define (make-combination operator operands) (cons operator operands)) + +(define (let->combination exp) + ;;make-combination defined in earlier exercise + (let ((bindings (let-bindings exp))) + (make-combination (make-lambda (map let-var bindings) + (let-body exp)) + (map let-val bindings)))) + + + +;; A longer list of primitives -- suitable for running everything in 4.3 +;; Overrides the list in ch4-mceval.scm +;; Has Not to support Require; various stuff for code in text (including +;; support for Prime?); integer? and sqrt for exercise code; +;; eq? for ex. solution + + + + +'AMB-EVALUATOR-LOADED diff --git a/454.scm b/454.scm new file mode 100755 index 0000000..49b4884 --- /dev/null +++ b/454.scm @@ -0,0 +1,533 @@ +(define apply-in-underlying-scheme apply) +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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) + (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 true #t) +(define false #f) +(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" vars vals) + (error "Too few arguments supplied" vars 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 'list list) + (list 'memq memq) + (list 'member member) + (list 'not not) + (list '+ +) + (list '- -) + (list '* *) + (list '= =) + (list '> >) + (list '>= >=) + (list 'abs abs) + (list 'remainder remainder) + (list 'integer? integer?) + (list 'sqrt sqrt) + (list 'eq? eq?) +;; more primitives + )) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + + +;;;Code from SECTION 4.3.3, modified as needed to run it + +(define (amb? exp) (tagged-list? exp 'amb)) +(define (amb-choices exp) (cdr exp)) + +;; analyze from 4.1.6, with clause from 4.3.3 added +;; and also support for Let +(define (analyze exp) + (cond ((self-evaluating? exp) + (analyze-self-evaluating exp)) + ((quoted? exp) (analyze-quoted exp)) + ((variable? exp) (analyze-variable exp)) + ((assignment? exp) (analyze-assignment exp)) + ((permanent-assignment? exp) (analyze-permanent-assignment exp)) + ((if-fail? exp) (analyze-if-fail exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (cond->if exp))) + ((let? exp) (analyze (let->combination exp))) ;** + ((amb? exp) (analyze-amb exp)) ;** + ((require? exp) (analyze-require exp)) + ((application? exp) (analyze-application exp)) + (else + (error "Unknown expression type -- ANALYZE" exp)))) + +(define (require? exp) (tagged-list? exp 'require)) +(define (require-predicate exp) (cadr exp)) + +(define (analyze-require exp) + (let ((pproc (analyze (require-predicate exp)))) + (lambda (env succeed fail) + (pproc env (lambda (pred-value fail2) + (if (not (true? pred-value)) + (fail2) + (succeed 'ok fail2))) + fail)))) + +(define (permanent-assignment? exp) (tagged-list? exp 'permanent-set!)) +(define (analyze-permanent-assignment exp) + (let ((var (assignment-variable exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env succeed fail) + (vproc env (lambda (val fail2) + (set-variable-value! var val env) + (succeed 'ok fail2)) + fail)))) + +(define (if-fail? exp) (tagged-list? exp 'if-fail)) +(define (analyze-if-fail exp) + (let ((first-exp (analyze (cadr exp))) + (second-exp (analyze (caddr exp)))) + (lambda (env succeed fail) + (first-exp env + (lambda (value fail1) + (succeed value fail1)) + (lambda () + (second-exp env succeed fail)))))) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +;;;Simple expressions + +(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)))) + +;;;Conditionals and sequences + +(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 + ;; success continuation for evaluating the predicate + ;; to obtain pred-value + (lambda (pred-value fail2) + (if (true? pred-value) + (cproc env succeed fail2) + (aproc env succeed fail2))) + ;; failure continuation for evaluating the predicate + fail)))) + +(define (analyze-sequence exps) + (define (sequentially a b) + (lambda (env succeed fail) + (a env + ;; success continuation for calling a + (lambda (a-value fail2) + (b env succeed fail2)) + ;; failure continuation for calling a + 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)))) + +;;;Definitions and assignments + +(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) ; *1* + (let ((old-value + (lookup-variable-value var env))) + (set-variable-value! var val env) + (succeed 'ok + (lambda () ; *2* + (set-variable-value! var + old-value + env) + (fail2))))) + fail)))) + +;;;Procedure applications + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operands exp)))) + (lambda (env succeed fail) + (fproc 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 + ;; success continuation for this aproc + (lambda (arg fail2) + (get-args (cdr aprocs) + env + ;; success continuation for recursive + ;; call to get-args + (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)))) + +;;;amb expressions + +(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)))) + +;;;Driver loop + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (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 + ;; ambeval success + (lambda (val next-alternative) + (announce-output output-prompt) + (user-print val) + (internal-loop next-alternative)) + ;; ambeval failure + (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)))) + + + +;;; Support for Let (as noted in footnote 56, p.428) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-bindings exp) (cadr exp)) +(define (let-body exp) (cddr exp)) + +(define (let-var binding) (car binding)) +(define (let-val binding) (cadr binding)) + +(define (make-combination operator operands) (cons operator operands)) + +(define (let->combination exp) + ;;make-combination defined in earlier exercise + (let ((bindings (let-bindings exp))) + (make-combination (make-lambda (map let-var bindings) + (let-body exp)) + (map let-val bindings)))) + + + +;; A longer list of primitives -- suitable for running everything in 4.3 +;; Overrides the list in ch4-mceval.scm +;; Has Not to support Require; various stuff for code in text (including +;; support for Prime?); integer? and sqrt for exercise code; +;; eq? for ex. solution + + + + +'AMB-EVALUATOR-LOADED diff --git a/46.scm b/46.scm new file mode 100755 index 0000000..9238bdb --- /dev/null +++ b/46.scm @@ -0,0 +1,387 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or exp env)) + ((let? exp) (eval (let->combination 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (if (null? parameters) + '() + (cons (caar parameters) + (let-variables (cdr parameters))))) +(define (let-exps parameters) + (if (null? parameters) + '() + (cons (cadar parameters) + (let-exps (cdr parameters))))) +(define (let->combination exp) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters)))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) diff --git a/47.scm b/47.scm new file mode 100755 index 0000000..b8c1a80 --- /dev/null +++ b/47.scm @@ -0,0 +1,404 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or exp env)) + ((let? exp) (eval (let->combination exp) env)) + ((let*? exp) (eval (let*->nested-lets 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (if (null? parameters) + '() + (cons (caar parameters) + (let-variables (cdr parameters))))) +(define (let-exps parameters) + (if (null? parameters) + '() + (cons (cadar parameters) + (let-exps (cdr parameters))))) +(define (let->combination exp) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters)))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (cons 'let + (cons parameters body))) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) diff --git a/48.scm b/48.scm new file mode 100755 index 0000000..6f04146 --- /dev/null +++ b/48.scm @@ -0,0 +1,417 @@ +(define (make-procedure-define var parameters body) + (list 'define (cons var parameters) body)) +(define (let->combination exp) + (if (pair? (cadr exp)) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters))) + (let ((arguments (cdr exp))) + (let ((var (car arguments)) + (parameters (map car (cadr arguments))) + (values (map cadr (cadr arguments)))) + (make-begin (list + (make-procedure-define var + parameters + (caddr arguments)) + (cons var values))))))) + +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((and? exp) (eval (and->if exp) env)) + ((or? exp) (eval-or exp env)) + ((let? exp) (eval (let->combination exp) env)) + ((let*? exp) (eval (let*->nested-lets 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (if (null? parameters) + '() + (cons (caar parameters) + (let-variables (cdr parameters))))) +(define (let-exps parameters) + (if (null? parameters) + '() + (cons (cadar parameters) + (let-exps (cdr parameters))))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (cons 'let + (cons parameters body))) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) +(driver-loop) diff --git a/49.scm b/49.scm new file mode 100755 index 0000000..e69de29 diff --git a/ambevaluator.rkt b/ambevaluator.rkt new file mode 100755 index 0000000..e45b80b --- /dev/null +++ b/ambevaluator.rkt @@ -0,0 +1,462 @@ +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +;;;from section 4.1.4 -- must precede def of metacircular apply +(define apply-in-underlying-scheme apply) + +(define (amb? exp) + (tagged-list? exp 'amb)) + +(define (amb-choices exp) + (cdr exp)) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +(define (analyze exp) + (cond [(self-evaluating? exp) + (analyze-self-evaluating exp)] + [(quoted? exp) + (analyze-quoted exp)] + [(variable? exp) + (analyze-variable exp)] + [(assignment? exp) + (analyze-assignment exp)] + [(definition? exp) + (analyze-definition exp)] + [(if? exp) + (analyze-if exp)] + [(lambda? exp) + (analyze-lambda exp)] + [(begin? exp) + (analyze-sequence (begin-actions exp))] + [(cond? exp) (analyze (cond->if exp))] + [(amb? exp) (analyze-amb exp)] + [(application? exp) (analyze-application exp)] + [#t + (error "Unknown expression type -- ANALYZE" exp)])) + +(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)))) + +(define (self-evaluating? exp) + (cond ((number? exp) #t) + ((string? exp) #t) + (else #f))) + +(define (analyze-self-evaluating exp) + (lambda (env succeed fail) + (succeed exp fail))) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (analyze-quoted exp) + (let ([qval (text-of-quotation exp)]) + (lambda (env succeed fail) + (succeed qval fail)))) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + #f)) + +(define (variable? exp) (symbol? exp)) + +(define (analyze-variable exp) + (lambda (env succeed fail) + (succeed (lookup-variable-value exp env) + fail))) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (assignment-value exp) (caddr exp)) + +(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 (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 (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 (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 (analyze-lambda exp) + (let ([var (lambda-parameters exp)] + [bproc (analyze-sequence (lambda-body exp))]) + (lambda (env succeed fail) + (succeed (make-procedure var bproc env) + fail)))) + +(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 (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 (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 (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 (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 (analyze-application exp) + (let ([fproc (analyze (operator exp))] + [aprocs (map analyze (operands exp))]) + (lambda (env succeed fail) + (fproc 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)] + [#t + (error "Unknown procedure type -- EXECUTE-APPLICATION" + proc)])) + +(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 ; no else clause + (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)))))) + +;;;SECTION 4.1.3 + +(define (true? x) + (not (eq? x #f))) + +(define (false? x) + (eq? x #f)) + + +(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" vars vals) + (error "Too few arguments supplied" vars 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)))) + +;;;SECTION 4.1.4 + +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-names) + (primitive-procedure-objects) + the-empty-environment))) + (define-variable! 'true #t initial-env) + (define-variable! 'false #f initial-env) + initial-env)) + +;[do later] (define the-global-environment (setup-environment)) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (primitive-implementation proc) (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) + (list 'list list) +;; more primitives + )) + +(define (primitive-procedure-names) + (map car + primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +;[moved to start of file] (define apply-in-underlying-scheme apply) + +(define (apply-primitive-procedure proc args) + (apply-in-underlying-scheme + (primitive-implementation proc) args)) + + + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") + +(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)))) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + +;;;Following are commented out so as not to be evaluated when +;;; the file is loaded. +(define the-global-environment (setup-environment)) +(driver-loop) diff --git a/ambevaluator.rkt~ b/ambevaluator.rkt~ new file mode 100755 index 0000000..e76fb60 --- /dev/null +++ b/ambevaluator.rkt~ @@ -0,0 +1,434 @@ +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +;;;from section 4.1.4 -- must precede def of metacircular apply +(define apply-in-underlying-scheme apply) + +(define (amb? exp) + (tagged-list? exp 'amb)) + +(define (amb-choices exp) + (cdr exp)) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +(define (require p) + (unless p (amb))) + +(define (analyze exp) + (cond [(self-evaluating? exp) + (analyze-self-evaluating exp)] + [(quoted? exp) + (analyze-quoted exp)] + [(variable? exp) + (analyze-variable exp)] + [(assignment? exp) + (analyze-assignment exp)] + [(definition? exp) + (analyze-definition exp)] + [(if? exp) + (analyze-if exp)] + [(lambda? exp) + (analyze-lambda exp)] + [(begin? exp) + (analyze-sequence (begin-actions exp))] + [(cond? exp) (analyze (cond->if exp))] + [(application? exp) (analyze-application exp)] + [#t + (error "Unknown expression type -- ANALYZE" exp)])) + + +(define (self-evaluating? exp) + (cond ((number? exp) #t) + ((string? exp) #t) + (else #f))) + +(define (analyze-self-evaluating exp) + (lambda (env succeed fail) + (succeed exp fail))) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (analyze-quoted exp) + (let ([qval (text-of-quotation exp)]) + (lambda (env succeed fail) + (succeed qval fail)))) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + #f)) + +(define (variable? exp) (symbol? exp)) + +(define (analyze-variable exp) + (lambda (env succeed fail) + (succeed (lookup-variable-value exp env) + fail))) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (assignment-value exp) (caddr exp)) + +(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 (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 (analyze-definition exp) + (let ([var (definition-variable exp)] + [vproc (definition-value exp)]) + (lambda (env succeed fail) + (vproc env + (lambda (val fail2) + (define-variable! var val env) + (succeed 'ok fail2)) + fail)))) + +(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 (analyze-lambda exp) + (let ([var (lambda-parameters exp)] + [bproc (analyze-sequence (lambda-body exp))]) + (lambda (env succeed fail) + (succeed (make-procedure vars bproc env) + fail)))) + +(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 (analyze-if exp) + (let ([pproc (analyze (if-predicate exp))] + [cproc (ananlyze (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 (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 (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 (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 (analyze-application exp) + (let ([fproc (analyze (operator exp))] + [aprocs (map analyze (operands exp))]) + (lambda (env succeed fail) + (fproc 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)] + [#t + (error "Unknown procedure type -- EXECUTE-APPLICATION" + proc)])) + +(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 ; no else clause + (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)))))) + +;;;SECTION 4.1.3 + +(define (true? x) + (not (eq? x #f))) + +(define (false? x) + (eq? x #f)) + + +(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" vars vals) + (error "Too few arguments supplied" vars 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)))) + +;;;SECTION 4.1.4 + +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-names) + (primitive-procedure-objects) + the-empty-environment))) + (define-variable! 'true #t initial-env) + (define-variable! 'false #f initial-env) + initial-env)) + +;[do later] (define the-global-environment (setup-environment)) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (primitive-implementation proc) (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) +;; more primitives + )) + +(define (primitive-procedure-names) + (map car + primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +;[moved to start of file] (define apply-in-underlying-scheme apply) + +(define (apply-primitive-procedure proc args) + (apply-in-underlying-scheme + (primitive-implementation proc) args)) + + + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") + +(define (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (lazy-eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + +;;;Following are commented out so as not to be evaluated when +;;; the file is loaded. +(define the-global-environment (setup-environment)) +(driver-loop) diff --git a/ch232.scm b/ch232.scm old mode 100644 new mode 100755 diff --git a/ch233.scm b/ch233.scm old mode 100644 new mode 100755 diff --git a/ch234.scm b/ch234.scm old mode 100644 new mode 100755 diff --git a/ch243.scm b/ch243.scm old mode 100644 new mode 100755 diff --git a/ch251.scm b/ch251.scm old mode 100644 new mode 100755 diff --git a/ch252.scm b/ch252.scm old mode 100644 new mode 100755 diff --git a/ch332.scm b/ch332.scm old mode 100644 new mode 100755 diff --git a/ch335.scm b/ch335.scm old mode 100644 new mode 100755 diff --git a/ch342.scm b/ch342.scm old mode 100644 new mode 100755 diff --git a/ch351.scm b/ch351.scm old mode 100644 new mode 100755 diff --git a/ch354.scm b/ch354.scm new file mode 100755 index 0000000..445c776 --- /dev/null +++ b/ch354.scm @@ -0,0 +1,27 @@ +(define (stream-enumerate-interval low high) + (if (> low high) + the-empty-stream + (cons-stream low + (stream-enumerate-interval (+ low 1) high)))) +(define (display-line x) + (newline) + (display x)) +(define (add-stream s1 s2) + (stream-map + s1 s2)) +(define (scale-stream s factor) + (stream-map (lambda (x) (* x factor)) + s)) +(define (stream-filter pred stream) + (cond ((stream-null? stream) the-empty-stream) + ((pred (stream-car stream)) + (cons-stream (stream-car stream) + (stream-filter pred (stream-cdr stream)))) + (else + (stream-filter pred (stream-cdr stream))))) +(define (integral delayed-integrand initial-value dt) + (define int + (cons-stream initial-value + (let ((integrand (force delayed-integrand))) + (add-stream (scale-stream integrand dt) + int)))) + int) diff --git a/ch4-ambeval.scm b/ch4-ambeval.scm new file mode 100755 index 0000000..a9ecb8e --- /dev/null +++ b/ch4-ambeval.scm @@ -0,0 +1,536 @@ +;;;;AMB EVALUATOR FROM SECTION 4.3 OF +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS + +;;;;Matches code in ch4.scm. +;;;; To run the sample programs and exercises, code below also includes +;;;; -- enlarged primitive-procedures list +;;;; -- support for Let (as noted in footnote 56, p.428) + +;;;;This file can be loaded into Scheme as a whole. +;;;;**NOTE**This file loads the metacircular evaluator of +;;;; sections 4.1.1-4.1.4, since it uses the expression representation, +;;;; environment representation, etc. +;;;; You may need to change the (load ...) expression to work in your +;;;; version of Scheme. +;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives +;;;; interface, due to renamings of apply). + +;;;;Then you can initialize and start the evaluator by evaluating +;;;; the two lines at the end of the file ch4-mceval.scm +;;;; (setting up the global environment and starting the driver loop). +;;;;In the driver loop, do +;(define (require p) +; (if (not p) (amb))) + + +;;**implementation-dependent loading of evaluator file +;;Note: It is loaded first so that the section 4.2 definition +;; of eval overrides the definition from 4.1.1 +(define apply-in-underlying-scheme apply) +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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) + (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 true #t) +(define false #f) +(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" vars vals) + (error "Too few arguments supplied" vars 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 'list list) + (list 'memq memq) + (list 'member member) + (list 'not not) + (list '+ +) + (list '- -) + (list '* *) + (list '= =) + (list '> >) + (list '>= >=) + (list 'abs abs) + (list 'remainder remainder) + (list 'integer? integer?) + (list 'sqrt sqrt) + (list 'eq? eq?) +;; more primitives + )) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + + +;;;Code from SECTION 4.3.3, modified as needed to run it + +(define (amb? exp) (tagged-list? exp 'amb)) +(define (amb-choices exp) (cdr exp)) + +;; analyze from 4.1.6, with clause from 4.3.3 added +;; and also support for Let +(define (analyze exp) + (cond ((self-evaluating? exp) + (analyze-self-evaluating exp)) + ((quoted? exp) (analyze-quoted exp)) + ((variable? exp) (analyze-variable exp)) + ((assignment? exp) (analyze-assignment exp)) + ((permanent-assignment? exp) (analyze-permanent-assignment exp)) + ((definition? exp) (analyze-definition exp)) + ((if? exp) (analyze-if exp)) + ((lambda? exp) (analyze-lambda exp)) + ((begin? exp) (analyze-sequence (begin-actions exp))) + ((cond? exp) (analyze (cond->if exp))) + ((let? exp) (analyze (let->combination exp))) ;** + ((amb? exp) (analyze-amb exp)) ;** + ((application? exp) (analyze-application exp)) + (else + (error "Unknown expression type -- ANALYZE" exp)))) + +(define (permanent-assignment? exp) (tagged-list? exp 'permanent-set!)) +(define (analyze-permanent-assignment exp) + (let ((var (assignment-variable exp)) + (vproc (analyze (assignment-value exp)))) + (lambda (env succeed fail) + (vproc env (lambda (val fail2) + (set-variable-value! var val env) + (succeed 'ok fail2)) + fail)))) + +(define (ambeval exp env succeed fail) + ((analyze exp) env succeed fail)) + +;;;Simple expressions + +(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)))) + +;;;Conditionals and sequences + +(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 + ;; success continuation for evaluating the predicate + ;; to obtain pred-value + (lambda (pred-value fail2) + (if (true? pred-value) + (cproc env succeed fail2) + (aproc env succeed fail2))) + ;; failure continuation for evaluating the predicate + fail)))) + +(define (analyze-sequence exps) + (define (sequentially a b) + (lambda (env succeed fail) + (a env + ;; success continuation for calling a + (lambda (a-value fail2) + (b env succeed fail2)) + ;; failure continuation for calling a + 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)))) + +;;;Definitions and assignments + +(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) ; *1* + (let ((old-value + (lookup-variable-value var env))) + (set-variable-value! var val env) + (succeed 'ok + (lambda () ; *2* + (set-variable-value! var + old-value + env) + (fail2))))) + fail)))) + +;;;Procedure applications + +(define (analyze-application exp) + (let ((fproc (analyze (operator exp))) + (aprocs (map analyze (operands exp)))) + (lambda (env succeed fail) + (fproc 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 + ;; success continuation for this aproc + (lambda (arg fail2) + (get-args (cdr aprocs) + env + ;; success continuation for recursive + ;; call to get-args + (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)))) + +;;;amb expressions + +(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)))) + +;;;Driver loop + +(define input-prompt ";;; Amb-Eval input:") +(define output-prompt ";;; Amb-Eval value:") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (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 + ;; ambeval success + (lambda (val next-alternative) + (announce-output output-prompt) + (user-print val) + (internal-loop next-alternative)) + ;; ambeval failure + (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)))) + + + +;;; Support for Let (as noted in footnote 56, p.428) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-bindings exp) (cadr exp)) +(define (let-body exp) (cddr exp)) + +(define (let-var binding) (car binding)) +(define (let-val binding) (cadr binding)) + +(define (make-combination operator operands) (cons operator operands)) + +(define (let->combination exp) + ;;make-combination defined in earlier exercise + (let ((bindings (let-bindings exp))) + (make-combination (make-lambda (map let-var bindings) + (let-body exp)) + (map let-val bindings)))) + + + +;; A longer list of primitives -- suitable for running everything in 4.3 +;; Overrides the list in ch4-mceval.scm +;; Has Not to support Require; various stuff for code in text (including +;; support for Prime?); integer? and sqrt for exercise code; +;; eq? for ex. solution + + + + +'AMB-EVALUATOR-LOADED diff --git a/ch4-leval.scm b/ch4-leval.scm new file mode 100755 index 0000000..9bfc1f4 --- /dev/null +++ b/ch4-leval.scm @@ -0,0 +1,516 @@ +;;;;LAZY EVALUATOR FROM SECTION 4.2 OF +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS + +;;;;Matches code in ch4.scm +;;;; Also includes enlarged primitive-procedures list + +;;;;This file can be loaded into Scheme as a whole. +;;;;**NOTE**This file loads the metacircular evaluator of +;;;; sections 4.1.1-4.1.4, since it uses the expression representation, +;;;; environment representation, etc. +;;;; You may need to change the (load ...) expression to work in your +;;;; version of Scheme. +;;;;**WARNING: Don't load mceval twice (or you'll lose the primitives +;;;; interface, due to renamings of apply). + +;;;;Then you can initialize and start the evaluator by evaluating +;;;; the two lines at the end of the file ch4-mceval.scm +;;;; (setting up the global environment and starting the driver loop). + + +;;;; To run without memoization, reload the first version of force-it below + + +;;**implementation-dependent loading of evaluator file +;;Note: It is loaded first so that the section 4.2 definition +;; of eval overrides the definition from 4.1.1 + + +;;;SECTION 4.2.2 + +;;; Modifying the evaluator +(define (make-procedure-define var parameters body) + (list 'define (cons var parameters) body)) +(define (let->combination exp) + (if (pair? (cadr exp)) + (let ((parameters (let-parameters exp))) + (cons + (make-lambda (let-variables parameters) + (let-body exp)) + (let-exps parameters))) + (let ((arguments (cdr exp))) + (let ((var (car arguments)) + (parameters (map car (cadr arguments))) + (values (map cadr (cadr arguments)))) + (make-begin (list + (make-procedure-define var + parameters + (caddr arguments)) + (cons var values))))))) + +(define apply-in-underlying-scheme apply) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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)) + (let ((actions (cond-actions first))) + (if (and (not (null? actions)) (eq? (car actions) '=>)) + (let ((predicate-result (list (cadr actions) (cond-predicate first)))) + (make-if (cond-predicate first) + predicate-result + (expand-clauses rest))) + (make-if (cond-predicate first) + (sequence->exp actions) + (expand-clauses rest)))))))) + +(define (let? exp) (tagged-list? exp 'let)) +(define (let-parameters exp) (cadr exp)) +(define (let-body exp) (cddr exp)) +(define (let-variables parameters) + (if (null? parameters) + '() + (cons (caar parameters) + (let-variables (cdr parameters))))) +(define (let-exps parameters) + (if (null? parameters) + '() + (cons (cadar parameters) + (let-exps (cdr parameters))))) + +(define (let*? exp) (tagged-list? exp 'let*)) +(define (let*-parameters exp) (cadr exp)) +(define (first-let*-parameter parameters) (car parameters)) +(define (rest-let*-parameters parameters) (cdr parameters)) +(define (let*-body exp) (caddr exp)) +(define (make-let parameters body) + (cons 'let + (cons parameters body))) +(define (expand-let*-clause parameters body) + (if (null? parameters) + (make-let '() body) + (make-let (list (first-let*-parameter parameters)) + (expand-let*-clause (rest-let*-parameters parameters) body)))) +(define (let*->nested-lets exp) + (expand-let*-clause (let*-parameters exp) (let*-body exp))) + +(define true #t) +(define false #f) +(define (true? x) + (not (eq? x false))) +(define (false? x) + (eq? x false)) +;; new adder +(define (and? exp) (tagged-list? exp 'and)) +(define (and-clauses exp) (cdr exp)) +(define (first-and-part exp) (car exp)) +(define (rest-and-part exp) (cdr exp)) +(define (eval-and exp env) + (define (evaln-and exp env) + (if (null? exp) + 'true + (let ((first-result (eval (first-and-part exp) env))) + (if (true? first-result) + (evaln-and (rest-and-part exp) env) + 'false)))) + (evaln-and (and-clauses exp) env)) + +(define (or? exp) (tagged-list? exp 'or)) +(define (or-clauses exp) (cdr exp)) +(define (first-or-part exp) (car exp)) +(define (rest-or-part exp) (cdr exp)) +(define (eval-or exp env) + (define (evaln-or exp env) + (if (null? exp) + 'false + (let ((first-result (eval (first-or-part exp) env))) + (if (true? first-result) + 'true + (evaln-or (rest-or-part exp) env))))) + (evaln-or (or-clauses exp) env)) + +(define (and->if exp) (expand-and-clauses (and-clauses exp))) +(define (expand-and-clauses clauses) + (if (null? clauses) + 'true + (make-if (first-and-part clauses) + (expand-and-clauses (rest-and-part clauses)) + 'false))) +(define (or-if exp) (expand-or-clauses (or-clauses exp))) +(define (expand-or-clauses clauses) + (if (null? exp) + 'false + (make-if (first-and-part clauses) + 'true + (expand-or-clauses (rest-or-part clauses))))) + +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cadr cadr) + (list 'cddr cddr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list 'pair? pair?) + (list '+ +) + (list '- -) + (list '* *) + (list '/ /) + (list '= =) + (list '> >) + (list '< <) + (list 'display display) + (list 'newline newline) + (list 'assoc assoc))) + +(define (primitive-procedure-name) + (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-name) + (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 (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + + +;; lazy part +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if exp) env)) + ((application? exp) ; clause from book + (apply (actual-value (operator exp) env) + (operands exp) + env)) + (else + (error "Unknown expression type -- EVAL" exp)))) + +(define (actual-value exp env) + (force-it (eval exp env))) + +(define (apply procedure arguments env) + (cond ((primitive-procedure? procedure) + (apply-primitive-procedure + procedure + (list-of-arg-values arguments env))) ; changed + ((compound-procedure? procedure) + (eval-sequence + (procedure-body procedure) + (extend-environment + (procedure-parameters procedure) + (list-of-delayed-args arguments env) ; changed + (procedure-environment procedure)))) + (else + (error + "Unknown procedure type -- APPLY" procedure)))) + +(define (list-of-arg-values exps env) + (if (no-operands? exps) + '() + (cons (actual-value (first-operand exps) env) + (list-of-arg-values (rest-operands exps) + env)))) + +(define (list-of-delayed-args exps env) + (if (no-operands? exps) + '() + (cons (delay-it (first-operand exps) env) + (list-of-delayed-args (rest-operands exps) + env)))) + +(define (eval-if exp env) + (if (true? (actual-value (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(define input-prompt ";;; L-Eval input:") +(define output-prompt ";;; L-Eval value:") + +(define (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output + (actual-value input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + + +;;; Representing thunks + +;; non-memoizing version of force-it + +(define (force-it obj) + (if (thunk? obj) + (actual-value (thunk-exp obj) (thunk-env obj)) + obj)) + +;; thunks + +(define (delay-it exp env) + (list 'thunk exp env)) + +(define (thunk? obj) + (tagged-list? obj 'thunk)) + +(define (thunk-exp thunk) (cadr thunk)) +(define (thunk-env thunk) (caddr thunk)) + +;; "thunk" that has been forced and is storing its (memoized) value +(define (evaluated-thunk? obj) + (tagged-list? obj 'evaluated-thunk)) + +(define (thunk-value evaluated-thunk) (cadr evaluated-thunk)) + + +;; memoizing version of force-it + +(define (force-it obj) + (cond ((thunk? obj) + (let ((result (actual-value + (thunk-exp obj) + (thunk-env obj)))) + (set-car! obj 'evaluated-thunk) + (set-car! (cdr obj) result) ; replace exp with its value + (set-cdr! (cdr obj) '()) ; forget unneeded env + result)) + ((evaluated-thunk? obj) + (thunk-value obj)) + (else obj))) + + +;; A longer list of primitives -- suitable for running everything in 4.2 +;; Overrides the list in ch4-mceval.scm + +'LAZY-EVALUATOR-LOADED + +;(driver-loop) diff --git a/ch4-mceval.scm b/ch4-mceval.scm new file mode 100755 index 0000000..1b6cb68 --- /dev/null +++ b/ch4-mceval.scm @@ -0,0 +1,357 @@ +;;;;METACIRCULAR EVALUATOR FROM CHAPTER 4 (SECTIONS 4.1.1-4.1.4) of +;;;; STRUCTURE AND INTERPRETATION OF COMPUTER PROGRAMS + +;;;;Matches code in ch4.scm + +;;;;This file can be loaded into Scheme as a whole. +;;;;Then you can initialize and start the evaluator by evaluating +;;;; the two commented-out lines at the end of the file (setting up the +;;;; global environment and starting the driver loop). + +;;;;**WARNING: Don't load this file twice (or you'll lose the primitives +;;;; interface, due to renamings of apply). + +;;;from section 4.1.4 -- must precede def of metacircular apply +(define apply-in-underlying-scheme apply) + +;;;SECTION 4.1.1 + +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +;;;SECTION 4.1.2 + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (variable? exp) (symbol? exp)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 (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 (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 ; no else clause + (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)))))) + +;;;SECTION 4.1.3 + +(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" vars vals) + (error "Too few arguments supplied" vars 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)))) + +;;;SECTION 4.1.4 + +(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)) + +;[do later] (define the-global-environment (setup-environment)) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (primitive-implementation proc) (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) +;; more primitives + )) + +(define (primitive-procedure-names) + (map car + primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +;[moved to start of file] (define apply-in-underlying-scheme apply) + +(define (apply-primitive-procedure proc args) + (apply-in-underlying-scheme + (primitive-implementation proc) args)) + + + +(define input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") + +(define (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + +;;;Following are commented out so as not to be evaluated when +;;; the file is loaded. +;;(define the-global-environment (setup-environment)) +;;(driver-loop) + +'METACIRCULAR-EVALUATOR-LOADED diff --git a/ch411.scm b/ch411.scm new file mode 100755 index 0000000..d251e94 --- /dev/null +++ b/ch411.scm @@ -0,0 +1,299 @@ +(define apply-in-underlying-scheme apply) +(define (eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (eval (cond->if 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 (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond ((number? exp) true) + ((string? exp) true) + (else false))) + +(define (variable? exp) (symbol? exp)) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) + (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + false)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 exp) (cons 'begin 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)) + +(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) + (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 true #t) +(define false #f) +(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" vars vals) + (error "Too few arguments supplied" vars 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-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?))) + +(define (primitive-procedure-name) + (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 input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-name) + (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 (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) diff --git a/change_money.scm b/change_money.scm old mode 100644 new mode 100755 diff --git a/compiled/drracket/errortrace/integerate-series_rkt.dep b/compiled/drracket/errortrace/integerate-series_rkt.dep new file mode 100644 index 0000000..94cce49 --- /dev/null +++ b/compiled/drracket/errortrace/integerate-series_rkt.dep @@ -0,0 +1 @@ +("6.7" ("0f6847578abe705d519fabc428f3b407e64933f2" . "9a744acf7bc4800a70cc4a3466b3d3fc7bc164ce") #"/home/green/work/sicp/stream.rkt" (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt") (collects #"rackunit" #"main.rkt")) diff --git a/compiled/drracket/errortrace/integerate-series_rkt.zo b/compiled/drracket/errortrace/integerate-series_rkt.zo new file mode 100644 index 0000000..f2db966 Binary files /dev/null and b/compiled/drracket/errortrace/integerate-series_rkt.zo differ diff --git a/compiled/drracket/errortrace/stream_rkt.dep b/compiled/drracket/errortrace/stream_rkt.dep new file mode 100644 index 0000000..187fb99 --- /dev/null +++ b/compiled/drracket/errortrace/stream_rkt.dep @@ -0,0 +1 @@ +("6.7" ("262e84ce3f2b639b9f065c674df638f1f61e7ed7" . "1aa655e6eb6939157a1d592ba709ec77c7425ded") (collects #"errortrace" #"errortrace-key.rkt") (collects #"racket" #"main.rkt") (collects #"racket" #"runtime-config.rkt")) diff --git a/compiled/drracket/errortrace/stream_rkt.zo b/compiled/drracket/errortrace/stream_rkt.zo new file mode 100644 index 0000000..28535dd Binary files /dev/null and b/compiled/drracket/errortrace/stream_rkt.zo differ diff --git a/constraint.rkt b/constraint.rkt new file mode 100644 index 0000000..9854c90 --- /dev/null +++ b/constraint.rkt @@ -0,0 +1,113 @@ +#lang racket + +(provide (all-defined-out)) + + +(define (make-connector) + (let ([value #f] + [informant #f] + [constraints '()]) + (define (set-my-value newval setter) + (cond [(not (has-value? me)) + (set! value newval) + (set! informant setter) + (for-each-except setter + inform-about-value + constraints)] + [(not (= value newval)) + (error "Contradiciton" (list value newval))] + [else 'ignored])) + (define (forget-my-value retractor) + (when (eq? informant retractor) + (begin (set! informant #f) + (for-each-except retractor + inform-about-no-value + constraints)))) + (define (connect new-constraint) + (unless (memq new-constraint constraints) + (set! constraints + (cons new-constraint constraints))) + (when (has-value? me) + (inform-about-value new-constraint)) + 'done) + (define (me request) + (cond [(eq? request 'has-value?) + (if informant #t #f)] + [(eq? request 'get-value) value] + [(eq? request 'set-value!) set-my-value] + [(eq? request 'forget) forget-my-value] + [(eq? request 'connect) connect] + [else + (error "Unknown operation -- CONNECTOR" request)])) + me)) + +(define (has-value? connector) + (connector 'has-value?)) +(define (get-value connector) + (connector 'get-value)) +(define (set-value! connector new-value informant) + ((connector 'set-value!) new-value informant)) +(define (forget-value! connector retractor) + ((connector 'forget) retractor)) +(define (connect connector new-constraint) + ((connector 'connect) new-constraint)) + +(define (for-each-except exception procedure list) + (for-each (lambda (x) (procedure x)) + (filter (lambda (x) (eq? x exception)) list)) + 'done) + +(define (inform-about-value constraint) + (constraint 'I-have-a-value)) +(define (inform-about-no-value constraint) + (constraint 'I-lost-my-value)) + +(define (adder a1 a2 sum) + (define (process-new-value) + (cond [(and (has-value? a1) (has-value? a2)) + (set-value! sum + (+ (get-value a1) (get-value a2)) + me)] + [(and (has-value? a1) (has-value? sum)) + (set-value! a2 + (- (get-value sum) (get-value a1)) + me)] + [(and (has-value? a2) (has-value? sum)) + (set-value! a1 + (- (get-value sum) (get-value a2)) + me)])) + (define (process-forget-value) + (forget-value! a1) + (forget-value! a2) + (forget-value! sum) + (process-new-value)) + (define (me request) + (cond [(eq? request 'I-have-a-value) (process-new-value)] + [(eq? request 'I-lost-my-value) (process-forget-value)] + [else + (error "Unknown request -- ADDER" request)])) + me) + +(define (constant value connector) + (define (me request) + (error "Unknown request -- CONSTANT" request)) + (connect connector me) + (set-value! connector value me)) + +(define (probe name connector) + (define (print-probe value) + (newline) + (display "Probe: ") + (display name) + (display " = ") + (display value)) + (define (process-new-value) + (print-probe (get-value connector))) + (define (process-forget-value) + (print-probe "?")) + (define (me request) + (cond [(eq? request 'I-have-a-value) (process-new-value)] + [(eq? request 'I-lost-my-value) (process-forget-value)] + [else + (error "Unknown request -- PROBE" request)])) + me) diff --git a/deriv.rkt b/deriv.rkt new file mode 100644 index 0000000..11d5d67 --- /dev/null +++ b/deriv.rkt @@ -0,0 +1,84 @@ +#lang racket + +(provide (all-defined-out)) + +(define ht (make-hash)) +(define (put op type item) + (hash-set! ht (cons op type) item)) +(define (get op type) + (hash-ref ht (cons op type))) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) + +(define (apply-generic op . args) + (let ([type-tags (map type-tag args)]) + (let ([proc (get op type-tags)]) + (if proc + (apply proc + (map contents args)) + (error + "No method for these types --- APPLY-GENERIC" + (list op type-tags)))))) + +(define (operator exp) (car exp)) +(define (operands exp) (cdr exp)) +(define (variable? exp) (symbol? exp)) +(define (same-variable? exp var) + (and (variable? exp) + (variable? var) + (eq? exp var))) +(define (deriv exp var) + (cond [(number? exp) 0] + [(variable? exp) + (if (same-variable? exp var) 1 0)] + [#t ((get 'deriv (operator exp)) + (operands exp) + var)])) + +(define (install-sum-package) + (define (added exp) (car exp)) + (define (augend exp) (cdr exp)) + (define (make-sum a b) (cons a b)) + (define (deriv-sum exp var) + (make-sum (deriv (added exp) var) + (deriv (augend exp) var))) + ;; interface + (define (tag x) (attach-tag 'sum x)) + (put 'deriv 'sum + (lambda (exp var) (tag (deriv-sum exp var)))) + (put 'make-sum 'sum + (lambda (x y) (tag (make-sum x y)))) + 'done + ) +(install-sum-package) +(define (make-sum x y) + ((get 'make-sum 'sum) x y)) + +(define (install-product-package) + (define (multiplicand exp) (car exp)) + (define (multiplier exp) (cdr exp)) + (define (make-product a b) (cons a b)) + (define (deriv-product exp var) + (make-sum + (make-product (multiplier exp) + (deriv (multiplicand exp) var)) + (make-product (multiplicand exp) + (deriv (multiplier exp) var)))) + (define (tag x) (attach-tag 'product x)) + (put 'deriv 'product + (lambda (exp var) (tag (deriv-product exp var)))) + (put 'make-product 'product + (lambda (x y) (tag (make-product x y)))) + 'done) +(install-product-package) +(define (make-product x y) + ((get 'make-product 'product) x y)) diff --git a/deriv.rkt~ b/deriv.rkt~ new file mode 100644 index 0000000..6f1f7b4 --- /dev/null +++ b/deriv.rkt~ @@ -0,0 +1 @@ +#lang racket diff --git a/digitele.rkt b/digitele.rkt new file mode 100644 index 0000000..d958c81 --- /dev/null +++ b/digitele.rkt @@ -0,0 +1,214 @@ +#lang racket + +(provide (all-defined-out)) + +;;; This part is for queue interferce +(define (make-queue) (mcons '() '())) +(define (front-ptr queue) (mcar queue)) +(define (rear-ptr queue) (mcdr queue)) +(define (set-front-ptr! queue item) (set-mcar! queue item)) +(define (set-rear-ptr! queue item) (set-mcdr! queue item)) +(define (empty-queue? queue) (null? (front-ptr queue))) + +(define (front-queue queue) + (if (empty-queue? queue) + (error "FRONT-QUEUE with empty queue" queue) + (mcar (front-ptr queue)))) +(define (insert-queue! queue item) + (let ([new-pair (mcons item null)]) + (if (empty-queue? queue) + (begin + (set-front-ptr! queue new-pair) + (set-rear-ptr! queue new-pair) + queue) + (begin + (set-mcdr! (rear-ptr queue) new-pair) + (set-rear-ptr! queue new-pair) + queue)))) +(define (delete-queue! queue) + (if (empty-queue? queue) + (error "DELETE-QUEUE with empty queue" queue) + (set-front-ptr! queue (mcdr (front-ptr queue))))) + + +;;; This part is for digit wire +(define (make-wire) + (let ([signal-value 0] [action-procedure '()]) + (define (set-my-signal! new-value) + (if (not (= new-value signal-value)) + (begin (set! signal-value new-value) + (call-each action-procedure)) + 'done)) + + (define (accept-action-procedure! proc) + (set! action-procedure (cons proc action-procedure)) + (proc)) + + (define (dispatch m) + (cond [(eq? m 'get-signal) signal-value] + [(eq? m 'set-signal!) set-my-signal!] + [(eq? m 'add-action!) accept-action-procedure!] + [else (error "Unknown operation --WIRE" m)])) + dispatch)) + +(define (call-each procedures) + (if (null? procedures) + 'done + (begin ((car procedures)) + (call-each (cdr procedures))))) + +(define (get-signal wire) + (wire 'get-signal)) + +(define (set-signal! wire new-value) + ((wire 'set-signal!) new-value)) + +(define (add-action! wire action-procedure) + ((wire 'add-action!) action-procedure)) + +(define (after-delay delay action) + (add-to-agenda! (+ delay (current-time the-agenda)) + action + the-agenda)) + +(define (propagate) + (if (empty-agenda? the-agenda) + 'done + (let ([first-item (first-agenda-item the-agenda)]) + (first-item) + (remove-first-agenda-item! the-agenda) + (propagate)))) + +(define (probe name wire) + (add-action! wire + (lambda () + (newline) + (display name) + (display " ") + (display (current-time the-agenda)) + (display " New-value = ") + (display (get-signal wire))))) + +(define (make-time-segment time queue) + (mcons time queue)) +(define (segment-time s) (mcar s)) +(define (segment-queue s) (mcdr s)) + +(define (make-agenda) (mcons 0 null)) +(define the-agenda (make-agenda)) + +(define (current-time agenda) (mcar agenda)) +(define (set-current-time! agenda time) + (set-mcar! agenda time)) +(define (segments agenda) (mcdr agenda)) +(define (set-segments! agenda segments) + (set-mcdr! agenda segments)) +(define (first-segment agenda) + (mcar (segments agenda))) +(define (rest-segments agenda) + (mcdr (segments agenda))) +(define (empty-agenda? agenda) + (null? (segments agenda))) + +(define (add-to-agenda! time action agenda) + (define (belong-before? segments) + (or (null? segments) + (< time (segment-time (mcar segments))))) + (define (make-new-time-segment time action) + (let ([q (make-queue)]) + (insert-queue! q action) + (make-time-segment time q))) + (define (add-to-segments! segments) + (if (= time (segment-time (mcar segments))) + (insert-queue! (segment-queue (mcar segments)) action) + (let ([rest (mcdr segments)]) + (if (belong-before? rest) + (set-mcdr! segments + (mcons (make-new-time-segment time action) rest)) + (add-to-segments! rest))))) + (let ([segments (segments agenda)]) + (if (belong-before? segments) + (set-segments! agenda + (mcons (make-new-time-segment time action) segments)) + (add-to-segments! segments)))) + +(define (remove-first-agenda-item! agenda) + (let ([q (segment-queue (first-segment agenda))]) + (delete-queue! q) + (when (empty-queue? q) + (set-segments! agenda (rest-segments agenda))))) + +(define (first-agenda-item agenda) + (if (empty-agenda? agenda) + (error "Agenda is empty -- FIRST-AGENDA-ITEM") + (let ([first-seg (first-segment agenda)]) + (set-current-time! agenda (segment-time first-seg)) + (front-queue (segment-queue first-seg))))) + +;;; This part is for gate circuit +(define (logical-not s) + (cond [(= s 0) 1] + [(= s 1) 0] + [else + (error "Invalid signal" s) ])) +(define (logical-and a b) + (cond [(and (= a 1) (= b 1)) 1] + [(or (= a 0) (= b 0)) 0] + [else + (error "Invalid signal" a b)])) +(define (logical-or a b) + (cond [(or (= a 1) (= b 1)) 1] + [(and (= a 0) (= b 0)) 0] + [else + (error "Invalid signal" a b)])) + +(define inverter-delay 1) + +(define (inverter input output) + (define (inverter-input) + (let ([new-value (logical-not (get-signal input))]) + (after-delay inverter-delay + (lambda () + (set-signal! output new-value))))) + (add-action! input inverter-input) + 'ok) + +(define and-gate-delay 2) +(define (and-gate a b output) + (define (and-action-procedure) + (let ([new-value (logical-and (get-signal a) (get-signal b))]) + (after-delay and-gate-delay + (lambda () + (set-signal! output new-value))))) + (add-action! a and-action-procedure) + (add-action! b and-action-procedure) + 'ok) + +(define or-gate-delay 2) +(define (or-gate a b output) + (define (or-action-procedure) + (let ([new-value (logical-or (get-signal a) (get-signal b))]) + (after-delay or-gate-delay + (lambda () + (set-signal! output new-value))))) + (add-action! a or-action-procedure) + (add-action! b or-action-procedure) + 'ok) + +(define (half-adder a b s c) + (let ([d (make-wire)] + [e (make-wire)]) + (or-gate a b d) + (and-gate a b c) + (inverter c e) + (and-gate d e s))) + +(define a (make-wire)) +(define b (make-wire)) +(define c (make-wire)) +(define s (make-wire)) +(probe "a" a) +(probe "b" b) +(probe "c" c) +(probe "s" s) +(half-adder a b s c) diff --git a/ex1-6.scm b/ex1-6.scm old mode 100644 new mode 100755 diff --git a/integerate-series.rkt b/integerate-series.rkt new file mode 100644 index 0000000..b4237f3 --- /dev/null +++ b/integerate-series.rkt @@ -0,0 +1,17 @@ +#lang racket + +(require rackunit "stream.rkt") +(provide (all-defined-out)) + +(define (integrate-series s) + (div-my-stream s + integers)) + +(define exp-series + (cons-my-stream 1 (integrate-series exp-series))) +(define cosine-series + (cons-my-stream 1 (my-stream-map + (lambda (x) (* -1 x)) + (integrate-series sine-series)))) +(define sine-series + (cons-my-stream 0 (integrate-series cosine-series))) diff --git a/integerate-series.rkt~ b/integerate-series.rkt~ new file mode 100644 index 0000000..32cc0de --- /dev/null +++ b/integerate-series.rkt~ @@ -0,0 +1,26 @@ +#lang racket + +(require rackunit "stream.rkt") + +(define (add-my-stream s1 s2) + (my-stream-map + s1 s2)) +(define (div-my-stream s1 s2) + (my-stream-map / s1 s2)) + +(define ones (cons-my-stream 1 ones)) +(define integers + (cons-my-stream 1 + (add-my-stream ones integers))) + +(define (integrate-series s) + (div-my-stream (my-stream-cdr s) + integers)) + +(define exp-series + (cons-my-stream 1 (integrate-series exp-series))) +(define cosine-series + (cons-my-stream 1 (stream-map + (lambda (x) (* -1 x)) + sine-series))) +(define sine-series + (cons-my-stream 0 cosine-series)) diff --git a/lazyevaluator.rkt b/lazyevaluator.rkt new file mode 100755 index 0000000..f65df8c --- /dev/null +++ b/lazyevaluator.rkt @@ -0,0 +1,395 @@ +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +;;;from section 4.1.4 -- must precede def of metacircular apply +(define apply-in-underlying-scheme apply) + +;;;SECTION 4.1.1 + +(define (lazy-eval exp env) + (cond ((self-evaluating? exp) exp) + ((variable? exp) (lookup-variable-value exp env)) + ((quoted? exp) (text-of-quotation exp)) + ((assignment? exp) (eval-assignment exp env)) + ((definition? exp) (eval-definition exp env)) + ((if? exp) (eval-if exp env)) + ((lambda? exp) + (make-procedure (lambda-parameters exp) + (lambda-body exp) + env)) + ((begin? exp) + (eval-sequence (begin-actions exp) env)) + ((cond? exp) (lazy-eval (cond->if exp) env)) + ((application? exp) + (lazy-apply (actual-value (operator exp) env) + (operands exp) env)) + (else + (error "Unknown expression type -- EVAL" exp)))) + +(define (lazy-apply procedure arguments env) + (cond ((primitive-procedure? procedure) + (apply-primitive-procedure + procedure + (list-of-arg-values arguments env))) + ((compound-procedure? procedure) + (eval-sequence + (procedure-body procedure) + (extend-environment + (procedure-parameters procedure) + (list-of-delayed-args arguments env) + (procedure-environment procedure)))) + (else + (error + "Unknown procedure type -- APPLY" procedure)))) + + +(define (list-of-arg-values exps env) + (if (no-operands? exps) + '() + (cons (actual-value (first-operand exps) env) + (list-of-arg-values (rest-operands exps) env)))) + +(define (list-of-delayed-args exps env) + (if (no-operands? exps) + '() + (cons (delay-it (first-operand exps) env) + (list-of-delayed-args (rest-operands exps) env)))) + +(define (actual-value exp env) + (force-it (lazy-eval exp env))) + +(define (delay-it exp env) + (list 'thunk exp env)) + +(define (thunk? obj) + (tagged-list? obj 'thunk)) + +(define (thunk-exp thunk) + (cadr thunk)) + +(define (thunk-env thunk) + (caddr thunk)) + +(define (evaluated-thunk? obj) + (tagged-list? obj 'evaluated-thunk)) + +(define (thunk-value evaluated-thunk) + (cadr evaluated-thunk)) + +(define (force-it obj) + (cond [(thunk? obj) + (let ([result (actual-value + (thunk-exp obj) + (thunk-env obj))]) + (set-car! obj 'evaluated-thunk) + (set-car! (cdr obj) result) + (set-cdr! (cdr obj) '()) + result)] + [(evaluated-thunk? obj) + (thunk-value obj)] + [#t obj])) + +(define (eval-if exp env) + (if (true? (actual-value (if-predicate exp) env)) + (lazy-eval (if-consequent exp) env) + (lazy-eval (if-alternative exp) env))) + +(define (eval-sequence exps env) + (cond ((last-exp? exps) (lazy-eval (first-exp exps) env)) + (else (lazy-eval (first-exp exps) env) + (eval-sequence (rest-exps exps) env)))) + +(define (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (lazy-eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (lazy-eval (definition-value exp) env) + env) + 'ok) + +;;;SECTION 4.1.2 + +(define (self-evaluating? exp) + (cond ((number? exp) #t) + ((string? exp) #t) + (else #f))) + +(define (quoted? exp) + (tagged-list? exp 'quote)) + +(define (text-of-quotation exp) (cadr exp)) + +(define (tagged-list? exp tag) + (if (pair? exp) + (eq? (car exp) tag) + #f)) + +(define (variable? exp) (symbol? exp)) + +(define (assignment? exp) + (tagged-list? exp 'set!)) + +(define (assignment-variable exp) (cadr exp)) + +(define (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 (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 (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 (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 (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 (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 ; no else clause + (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)))))) + +;;;SECTION 4.1.3 + +(define (true? x) + (not (eq? x #f))) + +(define (false? x) + (eq? x #f)) + + +(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" vars vals) + (error "Too few arguments supplied" vars 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)))) + +;;;SECTION 4.1.4 + +(define (setup-environment) + (let ((initial-env + (extend-environment (primitive-procedure-names) + (primitive-procedure-objects) + the-empty-environment))) + (define-variable! 'true #t initial-env) + (define-variable! 'false #f initial-env) + initial-env)) + +;[do later] (define the-global-environment (setup-environment)) + +(define (primitive-procedure? proc) + (tagged-list? proc 'primitive)) + +(define (primitive-implementation proc) (cadr proc)) + +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'null? null?) +;; more primitives + )) + +(define (primitive-procedure-names) + (map car + primitive-procedures)) + +(define (primitive-procedure-objects) + (map (lambda (proc) (list 'primitive (cadr proc))) + primitive-procedures)) + +;[moved to start of file] (define apply-in-underlying-scheme apply) + +(define (apply-primitive-procedure proc args) + (apply-in-underlying-scheme + (primitive-implementation proc) args)) + + + +(define input-prompt ";;; M-Eval input:") +(define output-prompt ";;; M-Eval value:") + +(define (driver-loop) + (prompt-for-input input-prompt) + (let ((input (read))) + (let ((output (lazy-eval input the-global-environment))) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) + +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + +;;;Following are commented out so as not to be evaluated when +;;; the file is loaded. +(define the-global-environment (setup-environment)) +(driver-loop) + +'METACIRCULAR-EVALUATOR-LOADED diff --git a/make-table.scm b/make-table.scm old mode 100644 new mode 100755 diff --git a/maketable.rkt b/maketable.rkt new file mode 100644 index 0000000..c554a09 --- /dev/null +++ b/maketable.rkt @@ -0,0 +1,47 @@ +#lang racket + +(provide (all-defined-out)) + +(define (make-table) (mcons '*table* null)) + +(define (lookup key table) + (let ([record (assoc key (mcdr table))]) + (if record + (mcdr record) + #f))) + +(define (assoc key records) + (cond [(null? records) #f] + [(equal? key (mcar (car records))) (car records)] + [else + (assoc key (cdr records))])) + +(define (insert! key value table) + (let ([record (assoc key (mcdr table))]) + (if record + (set-mcdr! record value) + (set-mcdr! table + (cons (mcons key value) (mcdr table)))))) + +(define (make-table2) (mcons '*doubletable* null)) + +(define (lookup2 key1 key2 table) + (let ([subtable (assoc key1 (mcdr table))]) + (if subtable + (let ([subrecord (assoc key2 (mcdr subtable))]) + (if subrecord + (mcdr subrecord) + #f)) + #f))) + +(define (insert2! key1 key2 value table) + (let ([record1 (assoc key1 (mcdr table))]) + (if record1 + (let ([record2 (assoc key2 (mcdr record1))]) + (if record2 + (set-mcdr! record2 value) + (set-mcdr! record1 (cons (mcons key2 value) (mcdr record1))))) + (set-mcdr! table + (cons (mcons key1 + (cons (mcons key2 value) null)) + (mcdr table)))))) diff --git a/metaevaluator.rkt b/metaevaluator.rkt new file mode 100755 index 0000000..a54ad44 --- /dev/null +++ b/metaevaluator.rkt @@ -0,0 +1,485 @@ +#! /usr/bin/env racket +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +(define apply-in-underlying-scheme apply) + +(define ht (make-eq-hashtable)) +(define (put op type item) + (if (hashtable-contains? ht op) + (let ([optable (hashtable-ref ht op #f)]) + (hashtable-set! optable type item)) + (let ([optable (make-eq-hashtable)]) + (hashtable-set! optable type item) + (hashtable-set! ht op optable)))) + +(define (get op type) + (hashtable-ref (hashtable-ref ht op #f) type #f)) + +(define (attach-tag type-tag contents) + (cons type-tag contents)) +(define (type-tag datum) + (if (pair? datum) + (car datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) +(define (contents datum) + (if (pair? datum) + (cdr datum) + (error "Bad tagged datum -- TYPE-TAG" datum))) + +(define (apply-meta op exp env) + (let ([type-tag (type-tag exp)]) + (let ([proc (get op type-tag)]) + (if proc + (proc exp env) + (if (application? exp) + (meta-apply (meta-eval (operator exp) env) + (list-of-values (operands exp) env)) + (error + "No method for these types --- APPLY-GENERIC" + (list op type-tag))))))) + +(define (meta-eval exp env) + (cond [(self-evaluating? exp) exp] + [(variable? exp) (lookup-variable-value exp env)] + [#t (apply-meta 'meta-eval exp env)] + )) + +(define (self-evaluating? exp) + (cond [(number? exp) #t] + [(string? exp) #t] + [#t #f])) + +(define (variable? exp) + (symbol? exp)) + +(define (tagged-list? exp tag) + (and (pair? exp) + (eq? (car exp) tag))) + +(define (install-quote-package) + (define (text-of-quotation exp) + (cadr exp)) + (define (eval-quote exp env) + (text-of-quotation exp)) + + ;; interface to the rest of system + (put 'meta-eval 'quote eval-quote) + ) +(install-quote-package) + +(define (install-assignment-package) + (define (assignment-variable exp) + (cadr exp)) + (define (assignment-value exp) + (caddr exp)) + (define (make-assignment var exp) + (list 'set! var exp)) + (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)] + [#t + (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 (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (meta-eval (assignment-value exp) env) + env) + 'ok) + + ;; interface to the rest of system + (define (tag x) (attach-tag 'set! x)) + (put 'meta-eval 'set! eval-assignment) + (put 'make-assignment 'set! make-assignment) + ) +(install-assignment-package) + +(define (make-assignment var exp) + ((get 'make-assignment 'set!) var exp)) + +(define (install-define-package) + (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 (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)] + [#t (scan (cdr vars) (cdr vals))])) + (scan (frame-variables frame) + (frame-values frame)))) + (define (eval-definition exp env) + (define-variable! (definition-variable exp) + (meta-eval (definition-value exp) env) + env) + 'ok) + + ;; interface to the rest of system + (define (tag x) (attach-tag 'define x)) + (put 'meta-eval 'define eval-definition) + (put 'define-variable! 'define define-variable!) + ) +(install-define-package) + +(define (define-variable! var val env) + ((get 'define-variable! 'define) var val env)) + +(define (install-lambda-package) + (define (lambda-parameter exp) + (cadr exp)) + (define (lambda-body exp) + (cddr exp)) + (define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + (define (eval-lambda exp env) + (make-procedure (lambda-parameter exp) + (lambda-body exp) + env)) + ;; interface to the rest of the system + (define (tag x) (attach-tag 'lambda x)) + (put 'meta-eval 'lambda eval-lambda) + (put 'make-lambda 'lambda make-lambda) + ) +(install-lambda-package) + +(define (make-lambda parameters body) + ((get 'make-lambda 'lambda) parameters body)) + +(define (install-let-package) + (define (let-body exp) + (cddr exp)) + (define (let-parameter exp) + (cadr exp)) + (define (let->combination args body) + (let ([vars (map car args)] + [exps (map cadr args)]) + (cons (make-lambda vars body) exps))) + (define (eval-let exp env) + (meta-eval + (let->combination (let-parameter exp) + (let-body exp)) + env)) + (define (make-let parameter body) + (cons 'let (cons parameter body))) + + ;; interface to the rest of system + (put 'meta-eval 'let eval-let) + (put 'make-let 'let make-let) + ) +(install-let-package) + +(define (make-let parameter body) + ((get 'make-let 'let) parameter body)) + +(define (install-let*-package) + (define (let*-body exp) + (cddr exp)) + (define (let*-parameter exp) + (cadr exp)) + (define (let*->nested-lets exp) + (define (let*->lets para body) + (if (or (null? para) (null? (cdr para))) + (make-let para body) + (let ([rest (let*->lets (cdr para) body)]) + (make-let (list (car para)) + (list rest))))) + (let*->lets (let*-parameter exp) + (let*-body exp))) + (define (eval-let* exp env) + (meta-eval (let*->nested-lets exp) env)) + + ;; interface to the rest of system + (put 'meta-eval 'let* eval-let*) + ) +(install-let*-package) + +(define (install-letrec-package) + (define (letrec-body exp) + (caddr exp)) + (define (letrec-parameter exp) + (cadr exp)) + (define (letrec->let exp) + (let ([para (letrec-parameter exp)] + [body (letrec-body exp)]) + (let ([vars (map car para)] + [vals (map cadr para)]) + (make-let (map (lambda (x) (list x ''*unassigned*)) vars) + (append (map (lambda (x y) (make-assignment x y)) vars vals) + (list body)))))) + (define (eval-letrec exp env) + (meta-eval (letrec->let exp) env)) + + ;; interface to the rest of the system + (put 'meta-eval 'letrec eval-letrec) + ) +(install-letrec-package) + +(define (install-if-package) + (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 (eval-if exp env) + (if (true? (meta-eval (if-predicate exp) env)) + (meta-eval (if-consequent exp) env) + (meta-eval (if-alternative exp) env))) + (define (make-if predicate consequent alternative) + (list 'if predicate consequent alternative)) + + ;; interface to the rest of the system + (define (tag x) (attach-tag 'if x)) + (put 'meta-eval 'if eval-if) + (put 'make-if 'if make-if) + ) +(install-if-package) + +(define (make-if predicate consequent alternative) + ((get 'make-if 'if) predicate consequent alternative)) + +(define (install-begin-package) + (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 (eval-sequence exps env) + (cond [(last-exp? exps) (meta-eval (first-exp exps) env)] + [#t (meta-eval (first-exp exps) env) + (eval-sequence (rest-exps exps) env)])) + (define (eval-begin exps env) + (eval-sequence (begin-actions exp) env)) + (define (sequence->exp seq) + (cond [(null? seq) seq] + [(last-exp? seq) (first-exp seq)] + [#t (make-begin seq)])) + (define (make-begin seq) + (cons 'begin seq)) + + ;; interface to the rest of the system + (define (tag x) (attach-tag 'begin x)) + (put 'meta-eval 'begin eval-begin) + (put 'make-begin 'begin make-begin) + (put 'sequence->exp 'begin sequence->exp) + (put 'eval-sequence 'begin eval-sequence) + ) +(install-begin-package) +(define (make-begin seq) + ((get 'make-begin 'begin) seq)) +(define (sequence->exp seq) + ((get 'sequence->exp 'begin) seq)) +(define (eval-sequence exp env) + ((get 'eval-sequence 'begin) exp env)) + +(define (install-cond-package) + (define (cond-clauses exp) + (cdr exp)) + (define (cond-else-clauses? 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) + #f + (let ([first (car clauses)] + [rest (cdr clauses)]) + (if (cond-else-clauses? first) + (if (null? rest) + (sequence->exp (cond-actions first)) + (error "ELSE clauses isn't last -- COND->IF" clauses)) + (make-if (cond-predicate first) + (sequence->exp (cond-actions first)) + (expand-clauses rest)))))) + (define (eval-cond exp env) + (meta-eval (cond->if exp) env)) + + ;; interface to the rest of the system + (define (tag x) (attach-tag 'cond x)) + (put 'meta-eval 'cond eval-cond) + ) +(install-cond-package) + +(define (true? x) + (not (eq? x #f))) +(define (false? x) + (eq? x #t)) + +(define (application? exp) + (pair? exp)) +(define (operator exp) + (car exp)) +(define (operands exp) + (cdr exp)) +(define (no-operands? ops) + (null? ops)) +(define (first-operands ops) + (car ops)) +(define (rest-operands ops) + (cdr ops)) + +(define (meta-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)))] + [#t + (error "Unknown procedure type -- APPLY" procedure)])) + +(define (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (meta-eval (first-operands exps) env) + (list-of-values (rest-operands exps) env)))) + +(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) + (error "Wrong match arguments supplied" vars 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)) + (if (eq? (car vals) '*unassigned*) + (error "Access unassigned variable" var) + (car vals))] + [#t + (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 (primitive-procedure? proc) + (tagged-list? proc 'primitive)) +(define (primitive-implementation proc) + (cadr proc)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'list list) + (list 'null? null?) + (list '* *) + (list '+ +) + (list '- -) + (list '/ /) + + )) + +(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 input-prompt ":::M-Eval input:") +(define output-prompt ":::M-Eval value:") +(define (driver-loop) + (prompt-for-input input-prompt) + (let ([input (read)]) + (let ([output (meta-eval input the-global-environment)]) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) + +(driver-loop) + + diff --git a/metaevaluator.rkt~ b/metaevaluator.rkt~ new file mode 100644 index 0000000..e5b092f --- /dev/null +++ b/metaevaluator.rkt~ @@ -0,0 +1,310 @@ +#lang racket + +(provide (all-defined-out)) + +(define (eval exp env) + (cond [(self-evaluating? exp) exp] + [(variable? exp) (lookup-variable-value exp env)] + [(quoted? exp) (text-of-quotation exp)] + [(assignment? exp) (eval-assignment exp env)] + [(definition? exp) (eval-definition exp env)] + [(if? exp) (eval-if exp env)] + [(lambda? exp) + (make-procedure (lambda-parameter exp) + (lambda-body exp) + env)] + [(cond? exp) (eval (cond->if exp) env)] + [(application? exp) + (apply (eval (operator exp) env) + (list-of-values (operands exp) env))] + [#t + (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)))] + [#t + (error "Unknown procedure type -- APPLY" procedure)])) + +(define (list-of-values exps env) + (if (no-operands? exps) + '() + (cons (eval (first-operand exps) env) + (list-of-values (rest-operands exps) env)))) + +(define (eval-if exp env) + (if (true? (eval (if-predicate exp) env)) + (eval (if-consequent exp) env) + (eval (if-alternative exp) env))) + +(define (eval-sequence exps env) + (cond [(last-exp? exps) (eval (first-exp exps) env)] + [#t (eval (first-exp exps) env) + (eval-sequence (rest-exps exps) env)])) + +(define (eval-assignment exp env) + (set-variable-value! (assignment-variable exp) + (eval (assignment-value exp) env) + env) + 'ok) + +(define (eval-definition exp env) + (define-variable! (definition-variable exp) + (eval (definition-value exp) env) + env) + 'ok) + +(define (self-evaluating? exp) + (cond [(number? exp) #t] + [(string? exp) #t] + [#t #f])) + +(define (variable? exp) + (symbol? exp)) + +(define (tagged-list? exp tag) + (and (pair? exp) + (eq? (car exp) tag))) + +(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 (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 (lambda? exp) + (tagged-list? exp 'lambda)) +(define (lambda-parameter exp) + (cadr exp)) +(define (lambda-body exp) + (cddr exp)) +(define (make-lambda parameters body) + (cons 'lambda (cons parameters body))) + +(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) + #f)) + +(define (make-if predicate consequent alternative) + (list 'if predicate consequent alternative)) + +(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-exp seq) + (cdr seq)) + +(define (sequence->exp seq) + (cond [(null? seq) seq] + [(last-exp? seq) (first-exp seq)] + [#t (make-begin seq)])) +(define (make-begin seq) + (cons 'begin seq)) + +(define (application? exp) + (pair? exp)) +(define (operator exp) + (car exp)) +(define (operands exp) + (cdr exp)) +(define (no-operands? ops) + (null? ops)) +(define (first-operands ops) + (car ops)) +(define (rest-operands ops) + (cdr ops)) + +(define (cond? exp) + (tagged-list? exp 'cond)) +(define (cond-clauses exp) + (cdr exp)) +(define (cond-else-clauses? exp) + (eq? (cond-predicate clause) 'else)) +(define (cond-predicate clause) + (car clause)) +(define (cond-actions clause) + (cdr clause)) + +(define (cond->if exp) + (expand-clause (cond-clauses exp))) +(define (expand-clauses clauses) + (if (null? clauses) + #f + (let ([first (car clauses)] + [rest (cdr clauses)]) + (if (cond-else-clauses? first) + (if (null? rest) + (sequence->exp (cond-actions first)) + (error "ELSE clauses isn't last -- COND->IF" clauses)) + (make-if (cond-predicate first) + (sequence->exp (cond-actions first)) + (expand-clauses rest)))))) + +(define (true? x) + (not (eq? x #f))) +(define (false? x) + (eq? x #t)) + +(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) + (mcons variables values)) +(define (frame-variables frame) + (mcar frame)) +(define (frame-values frame) + (mcdr frame)) + +(define (add-binding-to-frame! var val frame) + (set-mcar! frame (mcons var (mcar frame))) + (set-mcdr! frame (mcons val (mcdr frame)))) + +(define (extend-environment vars vals base-env) + (if (= (length vars) (length vals)) + (cons (make-frame vars vals) base-env) + (error "Wrong match arguments supplied" vars 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)] + [#t + (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-values! var val env) + (define (env-loop env) + (define (scan vars vals) + (cond [(null? vars) + (env-loop (enclosing-environment env))] + [(eq? var (car vars)) + (set-mcar! vals val)] + [#t + (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-mcar! vals val)] + [#t (scan (cdr vars) (cdr vals))])) + (scan (frame-variables frame) + (frame-values frame)))) + +(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)) +(define primitive-procedures + (list (list 'car car) + (list 'cdr cdr) + (list 'cons cons) + (list 'list list) + (list 'null? null?))) + +(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 apply-in-underlying-scheme apply) + +(define input-prompt ":::M-Eval input:") +(define output-prompt ":::M-Eval value:") +(define (driver-loop) + (prompt-for-input input-prompt) + (let ([input (read)]) + (let ([output (eval input the-global-environment)]) + (announce-output output-prompt) + (user-print output))) + (driver-loop)) +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) +(define (announce-output string) + (newline) (display string) (newline)) + +(define (user-print object) + (if (compound-procedure? object) + (display (list 'compound-procedure + (procedure-parameters object) + (procedure-body object) + ')) + (display object))) diff --git a/prime.scm b/prime.scm old mode 100644 new mode 100755 diff --git a/problems.rkt b/problems.rkt new file mode 100644 index 0000000..d4a7191 --- /dev/null +++ b/problems.rkt @@ -0,0 +1,121 @@ +#lang racket + +(provide (all-defined-out)) + +(define (reverse-rec s) + (cond [(null? s) s] + [else + (append (reverse-rec (cdr s)) (list (car s)))])) + +(define (reverse-ite s) + (define (reverse-acc r acc) + (if (null? r) + acc + (reverse-acc (cdr r) (cons (car r) acc)))) + (reverse-acc s null)) + +(define (subset s) + (if (null? s) + (list '()) + (let ([rest (subset (cdr s))] + [first (list (car s))]) + (append rest + (map (lambda (x) (append x first)) rest))))) + +(define (accumulate op initial sequence) + (if (null? sequence) + initial + (op (car sequence) + (accumulate op initial (cdr sequence))))) + +(define (accumulate-n op init seqs) + (cond [(null? (car seqs)) null] + [else + (cons (accumulate op init (map car seqs)) + (accumulate-n op init (map cdr seqs)))])) + +(define (fold-left op initial sequence) + (if (null? sequence) + initial + (fold-left op (op initial (car sequence)) + (cdr sequence)))) + +(define (enumerate-interval low high) + (if (> low high) + null + (cons low + (enumerate-interval (+ low 1) + high)))) + +(define (flatmap proc seq) + (accumulate append null (map proc seq))) + +(define (unique-pairs n) + (flatmap (lambda (x) (map (lambda (y) (cons x y)) (enumerate-interval 1 (- x 1)))) (enumerate-interval 1 n))) + +(define (tri-unique-pairs-s n s) + (filter (lambda (x) (= (+ (car x) (cadr x) (caddr x)) s)) + (flatmap (lambda (x) (flatmap (lambda (y) (map (lambda (z) (list z y x)) (enumerate-interval 1 (- y 1)))) (enumerate-interval 1 (- x 1)))) (enumerate-interval 1 n)))) + + +;;; This part is for mobile +(define (make-mobile left right) + (list left right)) +(define (make-branch length structure) + (list length structure)) +(define (left-branch mobile) + (car mobile)) +(define (right-branch mobile) + (cadr mobile)) +(define (branch-length branch) + (car branch)) +(define (branch-structure branch) + (cadr branch)) +(define (total-weight mobile) + (+ (branch-weight (left-branch mobile)) + (branch-weight (right-branch mobile)))) +(define (branch-weight branch) + (let ([st (branch-structure branch)]) + (cond [(integer? st) st] + [(pair? st) (total-weight st)] + [else (error "TOTAL-WEIGHT wrong structure" st)]))) +(define (mobile-balance mobile) + (define (branch-balance branch) + (let ([st (branch-structure branch)]) + (cond [(integer? st) #t] + [(pair? st) (mobile-balance st)] + [else (error "MOBILE-BALANCE wrong structure" st)]))) + (let ([left (left-branch mobile)] + [right (right-branch mobile)]) + (and (= (* (branch-length left) (branch-weight left)) + (* (branch-length right) (branch-weight right))) + (and (branch-balance left) (branch-balance right))))) + +;;; This part is for eight queens +(define (queens board-size) + (define (queen-col k) + (if (= k 0) + (list empty-board) + (filter (lambda (board) (safe? k board)) + (flatmap (lambda (positions) + (map (lambda (i) + (adjoin-position i k positions)) + (enumerate-interval 1 board-size))) + (queen-col (- k 1)))))) + (queen-col board-size)) + +(define empty-board null) +(define (adjoin-position new-row k rest-of-queens) + (cons new-row rest-of-queens)) +(define (safe? col positions) + (let ([row (car positions)] + [rest (cdr positions)]) + (define (check-iter rest d) + (if (null? rest) + #t + (let ([cur (car rest)]) + (and (not (or (= cur row) + (= cur (+ row d)) + (= cur (- row d)))) + (check-iter (cdr rest) (+ d 1)))))) + (check-iter rest 1))) diff --git a/queryevaluator.rkt b/queryevaluator.rkt new file mode 100755 index 0000000..c7c6565 --- /dev/null +++ b/queryevaluator.rkt @@ -0,0 +1,572 @@ +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +(define input-prompt ";;; Query input: ") +(define output-prompt ";;; Query results: ") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + + +(define (query-driver-loop) + (prompt-for-input input-prompt) + (let ([q (query-syntax-process (read))]) + (cond [(assertion-to-be-added? q) + (add-rule-or-assertion! (add-assertion-body q)) + (newline) + (display "Assertion added to date base.") + (query-driver-loop)] + [#t + (newline) + (display output-prompt) + (display-stream + (stream-map + (lambda (frame) + (instantiate q + frame + (lambda (v f) + (contract-question-mark v)))) + (qeval q (singleton-stream '())))) + (query-driver-loop)]))) + +(define (instantiate exp frame unbound-var-handler) + (define (copy exp) + (cond [(var? exp) + (let ([binding (binding-in-frame exp frame)]) + (if binding + (copy (binding-value binding)) + (unbound-var-handler exp frame)))] + [(pair? exp) + (cons (copy (car exp)) + (copy (cdr exp)))] + [#t + exp])) + (copy exp)) + +(define (qeval query frame-stream) + (let ([qproc (get (type query) 'qeval)]) + (if qproc + (qproc (contents query) frame-stream) + (simple-query query frame-stream)))) + +(define (simple-query query-pattern frame-stream) + (stream-flatmap + (lambda (frame) + (stream-append-delayed + (find-assertions query-pattern frame) + (delay (apply-rules query-pattern frame)))) + frame-stream)) + +(define (conjoin conjuncts frame-stream) + (if (empty-conjunction? conjuncts) + frame-stream + (conjoin (rest-conjuncts conjuncts) + (qeval (first-conjunct conjuncts) + frame-stream)))) +(put 'and 'qeval conjoin) + +(define (disjoin disjuncts frame-stream) + (if (empty-disjunction? disjuncts) + the-empty-stream + (interleave-delayed + (qeval (first-disjunct disjuncts) frame-stream) + (delay (disjoin (rest-disjuncts disjuncts) + frame-stream))))) +(put 'or 'qeval disjoin) + +(define (negate operands frame-stream) + (stream-flatmap + (lambda (frame) + (if (stream-null? (qeval (negated-query operands) + (singleton-stream frame))) + (singleton-stream frame) + the-empty-stream)) + frame-stream)) +(put 'not 'qeval negate) + +(define (lisp-value call frame-stream) + (stream-flatmap + (lambda (frame) + (if (execute + (instantiate + call + frame + (lambda (v f) + (error "Unknown pat var -- LISP-VALUE" v)))) + (singleton-stream frame) + the-empty-stream)) + frame-stream)) +(put 'lisp-value 'qeval lisp-value) + +(define (execute exp) + (apply (eval (predicate exp) user-initial-environment) + (args exp))) + +(deifne (always-true ignore frame-stream) frame-stream) +(put 'always-true 'qeval always-true) + +(define (find-assertions pattern frame) + (stream-flatmap (lambda (datum) + (check-an-assertion datum pattern frame)) + (fetch-assertions pattern frame))) + +(define (check-an-assertion assertion query-pat query-frame) + (let ([match-result + (pattern-match query-pat assertion query-frame)]) + (if (eq? match-result 'failed) + the-empty-stream + (singleton-stream match-result)))) + +(define (pattern-match pat dat frame) + (cond [(eq? frame 'failed) 'failed] + [(equal? pat dat) frame] + [(var? pat) (extend-if-consistent pat dat frame)] + [(and (pair? pat) (pair? dat)) + (pattern-match (cdr pat) + (cdr dat) + (pattern-match (car pat) + (car dat) + frame))] + [#t 'failed])) + +(define (extend-if-consistent var dat frame) + (let ([binding (binding-in-frame var frame)]) + (if binding + (pattern-match (binding-value binding) dat frame) + (extend var dat frame)))) + +(define (apply-rules pattern frame) + (stream-flatmap (lambda (rule) + (apply-a-rule rule pattern frame)) + (fetch-rules pattern frame))) + +(define (apply-a-rule rule query-pattern query-frame) + (let ([clean-rule (rename-variables-in rule)]) + (let ([unify-rusult + (unify-match query-pattern + (conclusion clean-rule) + query-frame)]) + (if (eq? unify-result 'failed) + the-empty-stream + (qeval (rule-body clean-rule) + (singleton-stream unify-result)))))) + +(define (rename-variable-in rule) + (let ([rule-application-id (new-rule-application-id)]) + (define (tree-walk exp) + (cond [(var? exp) + (make-new-variable exp rule-application-id)] + [(pair? exp) + (cons (tree-walk (car exp)) + (tree-walk (cdr exp)))] + [#t exp])) + (tree-walk rule))) + +(define (unify-match p1 p2 frame) + (cond [(eq? frame 'failed) 'failed] + [(equal? p1 p2) frame] + [(var? p1) (extend-if-possible p1 p2 frame)] + [(var? p2) (extend-if-possible p2 p1 frame)] + [(and (pair? p1) (pair? p2)) + (unify-match (cdr p1) + (cdr p2) + (unify-match (car p1) + (car p2) + frame))] + [#t 'failed])) + +(define (extend-if-possible var val frame) + (let ([binding (binding-in-frame var frame)]) + (cond [binding + (unify-match + ((binding-value binding) val frame))] + [(var? val) + (let ([binding (binding-in-frame val frame)]) + (if binding + (unify-match + var (binding-value binding) frame) + (extend var val frame)))] + [(depends-on? val var frame) + 'failed] + [#t + (extend var val frame)]))) + +(define (depends-on? exp var frame) + (define (tree-walk e) + (cond [(var? e) + (if (equal? var e) + #t + (let ([b (binding-in-frame e frame)]) + (if b + (tree-walk (binding-value b)) + #f)))] + [(pair? e) + (or (tree-walk (car e)) + (tree-walk (cdr e)))] + [#t #f])) + (tree-walk exp)) + +(define THE-ASSERTIONS the-empty-stream) + +(define (fetch-assertions pattern frame) + (if (use-index? pattern) + (get-indexed-assertions pattern) + (get-all-assertions))) + +(define (get-all-assertions) THE-ASSERTIONS) +(define (get-indexed-assertions pattern) + (get-stream (index-key-of pattern) 'assertion-stream)) +(define (get-stream key1 key2) + (let ([s (get key1 key2)]) + (if s s the-empty-stream))) + +(define THE-RULES the-empty-stream) +(define (fetch-rules pattern frame) + (if (use-index? pattern) + (get-indexed-rules pattern) + (get-all-rules))) +(define (get-all-rules) THE-RULES) +(define (get-indexed-rules pattern) + (stream-append + (get-stream (index-key-of pattern) 'rule-stream) + (get-stream '? 'rule-stream))) + +(define (add-rule-or-assertion! assertion) + (if (rule? assertion) + (add-rule! assertion) + (add-assertion! assertion))) + +(define (add-assertion! assertion) + (store-assertion-in-index assertion) + (let ([old-assertions THE-ASSERTIONS]) + (set! THE-ASSERTIONS + (cons-stream assertion old-assertions)) + 'ok)) + +(define (add-rule! rule) + (store-rule-in-index rule) + (let ([old-rules THE-RULES]) + (set! THE-RULES + (cons-stream rule old-rules)) + 'ok)) + +(define (store-assertion-in-index assertion) + (if (indexable? assertion) + (let ([key (index-key-of assertion)]) + (let ([current-assertion-stream + (get-stream key 'assertion-stream)]) + (put key + 'assertion-stream + (cons-stream assertion + current-assertion-stream)))))) + +(define (indexable? pat) + (or (constant-symbol? (car pat)) + (var? (car pat)))) + +(define (index-key-of pat) + (let ([key (car pat)]) + (if (var? key) '? key))) + +(define (use-index? pat) + (constant-symbol? (car pat))) + +(define (stream-append-delayed s1 delayed-s2) + (if (stream-null? s1) + (force delayed-s2) + (cons-stream + (stream-car s1) + (stream-append-delyed (stream-cdr s1) + delayed-s2)))) + +(define (interleave-delayed s1 delayed-s2) + (if (stream-null? s1) + (force delayed-s2) + (cons-stream + (stream-car s1) + (interleave-delayed (force delayed-s2) + (delay (stream-cdr s1)))))) + +(define (stream-flatmap proc s) + (flatten-stream (stream-map proc s))) + +(define (flatten-stream stream) + (if (stream-null? stream) + the-empty-stream + (interleave-delayed + (stream-car stream) + (delay (flatten-stream (stream-cdr stream)))))) + +(define (singleton-stream x) + (cons-stream x the-empty-stream)) + +(define (type exp) + (if (pair? exp) + (car exp) + (error "Unknown expression TYPE" exp))) + +(define (contents exp) + (if (pair? exp) + (cdr exp) + (error "Unknown expression CONTENTS" exp))) + +(define (assertion-to-be-added? exp) + (eq? (type exp) 'assert!)) + +(define (add-assertion-body exp) + (car (contents exp))) + +(define (empty-conjunction? exps) (null? exps)) +(define (first-conjunct exps) (car exps)) +(define (rest-conjucnts exps) (cdr exps)) + +(define (empty-disjunctions? exps) (null? exps)) +(define (first-disjunct exps) (car exps)) +(define (rest-disjuncts exps) (cdr exps)) + +(define (negated-query exps) (car exps)) +(define (predicate exps) (car exps)) +(define (args exps) (cdr exps)) + +(define (rule? statement) + (tagged-list? statement 'rule)) +(define (conclusion rule) + (cadr rule)) +(define (rule-body rule) + '(always-true) + (caddr rule)) + +(define (query-syntax-process exp) + (map-over-symbols expand-question-mark exp)) +(define (map-over-symbols proc exp) + (cond [(pair? exp) + (cons (map-over-symbols proc (car exp)) + (map-over-symbols proc (cdr exp)))] + [(symbol? exp) (proc exp)] + [#t exp])) +(define (expand-question-mark symbol) + (let ([chars (symbol->string symbol)]) + (if (string=? (substring chars 0 1) "?") + (list '? + (string->symbol + (substring chars 1 (string-length chars)))) + symbol))) + +(define (var? exp) + (tagged-list? exp '?)) +(define (constant-symbol? exp) + (symbol? exp)) +(define rule-counter 0) +(define (new-rule-application-id) + (set! rule-counter (+ 1 rule-counter)) + rule-counter) +(define (make-new-variable var rule-application-id) + (cons '? (cons rule-application-id (cdr var)))) +(define (contract-question-mark variable) + (string->symbol + (string-append "?" + (if (number? (cadr variable)) + (string-append (symbol->string (caddr variable)) + "-" + (number-string (cadr variable))) + (symbol->string (cadr variable)))))) + +(define (make-binding variable value) + (cons variable value)) +(define (binding-variable binding) + (car binding)) +(define (binding-value binding) + (cdr binding)) +(define (binding-in-frame variable frame) + (assoc variable frame)) +(define (extend variable value frame) + (cons (make-binding variable value) frame)) + +;;;;Stream support from Chapter 3 + +(define (stream-map proc s) + (if (stream-null? s) + the-empty-stream + (cons-stream (proc (stream-car s)) + (stream-map proc (stream-cdr s))))) + +(define (stream-for-each proc s) + (if (stream-null? s) + 'done + (begin (proc (stream-car s)) + (stream-for-each proc (stream-cdr s))))) + +(define (display-stream s) + (stream-for-each display-line s)) +(define (display-line x) + (newline) + (display x)) + +(define (stream-filter pred stream) + (cond ((stream-null? stream) the-empty-stream) + ((pred (stream-car stream)) + (cons-stream (stream-car stream) + (stream-filter pred + (stream-cdr stream)))) + (else (stream-filter pred (stream-cdr stream))))) + +(define (stream-append s1 s2) + (if (stream-null? s1) + s2 + (cons-stream (stream-car s1) + (stream-append (stream-cdr s1) s2)))) + +(define (interleave s1 s2) + (if (stream-null? s1) + s2 + (cons-stream (stream-car s1) + (interleave s2 (stream-cdr s1))))) + +;;;;Table support from Chapter 3, Section 3.3.3 (local tables) + +(define (make-table) + (let ((local-table (list '*table*))) + (define (lookup key-1 key-2) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (cdr record) + false)) + false))) + (define (insert! key-1 key-2 value) + (let ((subtable (assoc key-1 (cdr local-table)))) + (if subtable + (let ((record (assoc key-2 (cdr subtable)))) + (if record + (set-cdr! record value) + (set-cdr! subtable + (cons (cons key-2 value) + (cdr subtable))))) + (set-cdr! local-table + (cons (list key-1 + (cons key-2 value)) + (cdr local-table))))) + 'ok) + (define (dispatch m) + (cond ((eq? m 'lookup-proc) lookup) + ((eq? m 'insert-proc!) insert!) + (else (error "Unknown operation -- TABLE" m)))) + dispatch)) + +;;;; From instructor's manual + +(define get '()) + +(define put '()) + +(define (initialize-data-base rules-and-assertions) + (define (deal-out r-and-a rules assertions) + (cond ((null? r-and-a) + (set! THE-ASSERTIONS (list->stream assertions)) + (set! THE-RULES (list->stream rules)) + 'done) + (else + (let ((s (query-syntax-process (car r-and-a)))) + (cond ((rule? s) + (store-rule-in-index s) + (deal-out (cdr r-and-a) + (cons s rules) + assertions)) + (else + (store-assertion-in-index s) + (deal-out (cdr r-and-a) + rules + (cons s assertions)))))))) + (let ((operation-table (make-table))) + (set! get (operation-table 'lookup-proc)) + (set! put (operation-table 'insert-proc!))) + (put 'and 'qeval conjoin) + (put 'or 'qeval disjoin) + (put 'not 'qeval negate) + (put 'lisp-value 'qeval lisp-value) + (put 'always-true 'qeval always-true) + (deal-out rules-and-assertions '() '())) + +;; Do following to reinit the data base from microshaft-data-base +;; in Scheme (not in the query driver loop) +;; (initialize-data-base microshaft-data-base) + +(define microshaft-data-base + '( +;; from section 4.4.1 +(address (Bitdiddle Ben) (Slumerville (Ridge Road) 10)) +(job (Bitdiddle Ben) (computer wizard)) +(salary (Bitdiddle Ben) 60000) + +(address (Hacker Alyssa P) (Cambridge (Mass Ave) 78)) +(job (Hacker Alyssa P) (computer programmer)) +(salary (Hacker Alyssa P) 40000) +(supervisor (Hacker Alyssa P) (Bitdiddle Ben)) + +(address (Fect Cy D) (Cambridge (Ames Street) 3)) +(job (Fect Cy D) (computer programmer)) +(salary (Fect Cy D) 35000) +(supervisor (Fect Cy D) (Bitdiddle Ben)) + +(address (Tweakit Lem E) (Boston (Bay State Road) 22)) +(job (Tweakit Lem E) (computer technician)) +(salary (Tweakit Lem E) 25000) +(supervisor (Tweakit Lem E) (Bitdiddle Ben)) + +(address (Reasoner Louis) (Slumerville (Pine Tree Road) 80)) +(job (Reasoner Louis) (computer programmer trainee)) +(salary (Reasoner Louis) 30000) +(supervisor (Reasoner Louis) (Hacker Alyssa P)) + +(supervisor (Bitdiddle Ben) (Warbucks Oliver)) + +(address (Warbucks Oliver) (Swellesley (Top Heap Road))) +(job (Warbucks Oliver) (administration big wheel)) +(salary (Warbucks Oliver) 150000) + +(address (Scrooge Eben) (Weston (Shady Lane) 10)) +(job (Scrooge Eben) (accounting chief accountant)) +(salary (Scrooge Eben) 75000) +(supervisor (Scrooge Eben) (Warbucks Oliver)) + +(address (Cratchet Robert) (Allston (N Harvard Street) 16)) +(job (Cratchet Robert) (accounting scrivener)) +(salary (Cratchet Robert) 18000) +(supervisor (Cratchet Robert) (Scrooge Eben)) + +(address (Aull DeWitt) (Slumerville (Onion Square) 5)) +(job (Aull DeWitt) (administration secretary)) +(salary (Aull DeWitt) 25000) +(supervisor (Aull DeWitt) (Warbucks Oliver)) + +(can-do-job (computer wizard) (computer programmer)) +(can-do-job (computer wizard) (computer technician)) + +(can-do-job (computer programmer) + (computer programmer trainee)) + +(can-do-job (administration secretary) + (administration big wheel)) + +(rule (lives-near ?person-1 ?person-2) + (and (address ?person-1 (?town . ?rest-1)) + (address ?person-2 (?town . ?rest-2)) + (not (same ?person-1 ?person-2)))) + +(rule (same ?x ?x)) + +(rule (wheel ?person) + (and (supervisor ?middle-manager ?person) + (supervisor ?x ?middle-manager))) + +(rule (outranked-by ?staff-person ?boss) + (or (supervisor ?staff-person ?boss) + (and (supervisor ?staff-person ?middle-manager) + (outranked-by ?middle-manager ?boss)))) +)) diff --git a/queryevaluator.rkt~ b/queryevaluator.rkt~ new file mode 100755 index 0000000..eb1aff1 --- /dev/null +++ b/queryevaluator.rkt~ @@ -0,0 +1,388 @@ +#!r6rs + +(import (rnrs) + (rnrs lists (6)) + (rnrs base (6)) + (rnrs mutable-pairs (6)) + (rnrs hashtables (6)) + (rnrs io simple (6))) + +(define input-prompt ";;; Query input: ") +(define output-prompt ";;; Query results: ") +(define (prompt-for-input string) + (newline) (newline) (display string) (newline)) + + +(define (query-driver-loop) + (prompt-for-input input-prompt) + (let ([q (query-syntax-process (read))]) + (cond [(assertion-to-be-added? q) + (add-rule-or-assertion! (add-assertion-body q)) + (newline) + (display "Assertion added to date base.") + (query-driver-loop)] + [#t + (newline) + (display output-prompt) + (display-stream + (stream-map + (lambda (frame) + (instantiate q + frame + (lambda (v f) + (contract-question-mark v)))) + (qeval q (singleton-stream '())))) + (query-driver-loop)]))) + +(define (instantiate exp frame unbound-var-handler) + (define (copy exp) + (cond [(var? exp) + (let ([binding (binding-in-frame exp frame)]) + (if binding + (copy (binding-value binding)) + (unbound-var-handler exp frame)))] + [(pair? exp) + (cons (copy (car exp)) + (copy (cdr exp)))] + [#t + exp])) + (copy exp)) + +(define (qeval query frame-stream) + (let ([qproc (get (type query) 'qeval)]) + (if qproc + (qproc (contents query) frame-stream) + (simple-query query frame-stream)))) + +(define (simple-query query-pattern frame-stream) + (stream-flatmap + (lambda (frame) + (stream-append-delayed + (find-assertions query-pattern frame) + (delay (apply-rules query-pattern frame)))) + frame-stream)) + +(define (conjoin conjuncts frame-stream) + (if (empty-conjunction? conjuncts) + frame-stream + (conjoin (rest-conjuncts conjuncts) + (qeval (first-conjunct conjuncts) + frame-stream)))) +(put 'and 'qeval conjoin) + +(define (disjoin disjuncts frame-stream) + (if (empty-disjunction? disjuncts) + the-empty-stream + (interleave-delayed + (qeval (first-disjunct disjuncts) frame-stream) + (delay (disjoin (rest-disjuncts disjuncts) + frame-stream))))) +(put 'or 'qeval disjoin) + +(define (negate operands frame-stream) + (stream-flatmap + (lambda (frame) + (if (stream-null? (qeval (negated-query operands) + (singleton-stream frame))) + (singleton-stream frame) + the-empty-stream)) + frame-stream)) +(put 'not 'qeval negate) + +(define (lisp-value call frame-stream) + (stream-flatmap + (lambda (frame) + (if (execute + (instantiate + call + frame + (lambda (v f) + (error "Unknown pat var -- LISP-VALUE" v)))) + (singleton-stream frame) + the-empty-stream)) + frame-stream)) +(put 'lisp-value 'qeval lisp-value) + +(define (execute exp) + (apply (eval (predicate exp) user-initial-environment) + (args exp))) + +(deifne (always-true ignore frame-stream) frame-stream) +(put 'always-true 'qeval always-true) + +(define (find-assertions pattern frame) + (stream-flatmap (lambda (datum) + (check-an-assertion datum pattern frame)) + (fetch-assertions pattern frame))) + +(define (check-an-assertion assertion query-pat query-frame) + (let ([match-result + (pattern-match query-pat assertion query-frame)]) + (if (eq? match-result 'failed) + the-empty-stream + (singleton-stream match-result)))) + +(define (pattern-match pat dat frame) + (cond [(eq? frame 'failed) 'failed] + [(equal? pat dat) frame] + [(var? pat) (extend-if-consistent pat dat frame)] + [(and (pair? pat) (pair? dat)) + (pattern-match (cdr pat) + (cdr dat) + (pattern-match (car pat) + (car dat) + frame))] + [#t 'failed])) + +(define (extend-if-consistent var dat frame) + (let ([binding (binding-in-frame var frame)]) + (if binding + (pattern-match (binding-value binding) dat frame) + (extend var dat frame)))) + +(define (apply-rules pattern frame) + (stream-flatmap (lambda (rule) + (apply-a-rule rule pattern frame)) + (fetch-rules pattern frame))) + +(define (apply-a-rule rule query-pattern query-frame) + (let ([clean-rule (rename-variables-in rule)]) + (let ([unify-rusult + (unify-match query-pattern + (conclusion clean-rule) + query-frame)]) + (if (eq? unify-result 'failed) + the-empty-stream + (qeval (rule-body clean-rule) + (singleton-stream unify-result)))))) + +(define (rename-variable-in rule) + (let ([rule-application-id (new-rule-application-id)]) + (define (tree-walk exp) + (cond [(var? exp) + (make-new-variable exp rule-application-id)] + [(pair? exp) + (cons (tree-walk (car exp)) + (tree-walk (cdr exp)))] + [#t exp])) + (tree-walk rule))) + +(define (unify-match p1 p2 frame) + (cond [(eq? frame 'failed) 'failed] + [(equal? p1 p2) frame] + [(var? p1) (extend-if-possible p1 p2 frame)] + [(var? p2) (extend-if-possible p2 p1 frame)] + [(and (pair? p1) (pair? p2)) + (unify-match (cdr p1) + (cdr p2) + (unify-match (car p1) + (car p2) + frame))] + [#t 'failed])) + +(define (extend-if-possible var val frame) + (let ([binding (binding-in-frame var frame)]) + (cond [binding + (unify-match + ((binding-value binding) val frame))] + [(var? val) + (let ([binding (binding-in-frame val frame)]) + (if binding + (unify-match + var (binding-value binding) frame) + (extend var val frame)))] + [(depends-on? val var frame) + 'failed] + [#t + (extend var val frame)]))) + +(define (depends-on? exp var frame) + (define (tree-walk e) + (cond [(var? e) + (if (equal? var e) + #t + (let ([b (binding-in-frame e frame)]) + (if b + (tree-walk (binding-value b)) + #f)))] + [(pair? e) + (or (tree-walk (car e)) + (tree-walk (cdr e)))] + [#t #f])) + (tree-walk exp)) + +(define THE-ASSERTIONS the-empty-stream) + +(define (fetch-assertions pattern frame) + (if (use-index? pattern) + (get-indexed-assertions pattern) + (get-all-assertions))) + +(define (get-all-assertions) THE-ASSERTIONS) +(define (get-indexed-assertions pattern) + (get-stream (index-key-of pattern) 'assertion-stream)) +(define (get-stream key1 key2) + (let ([s (get key1 key2)]) + (if s s the-empty-stream))) + +(define THE-RULES the-empty-stream) +(define (fetch-rules pattern frame) + (if (use-index? pattern) + (get-indexed-rules pattern) + (get-all-rules))) +(define (get-all-rules) THE-RULES) +(define (get-indexed-rules pattern) + (stream-append + (get-stream (index-key-of pattern) 'rule-stream) + (get-stream '? 'rule-stream))) + +(define (add-rule-or-assertion! assertion) + (if (rule? assertion) + (add-rule! assertion) + (add-assertion! assertion))) + +(define (add-assertion! assertion) + (store-assertion-in-index assertion) + (let ([old-assertions THE-ASSERTIONS]) + (set! THE-ASSERTIONS + (cons-stream assertion old-assertions)) + 'ok)) + +(define (add-rule! rule) + (store-rule-in-index rule) + (let ([old-rules THE-RULES]) + (set! THE-RULES + (cons-stream rule old-rules)) + 'ok)) + +(define (store-assertion-in-index assertion) + (if (indexable? assertion) + (let ([key (index-key-of assertion)]) + (let ([current-assertion-stream + (get-stream key 'assertion-stream)]) + (put key + 'assertion-stream + (cons-stream assertion + current-assertion-stream)))))) + +(define (indexable? pat) + (or (constant-symbol? (car pat)) + (var? (car pat)))) + +(define (index-key-of pat) + (let ([key (car pat)]) + (if (var? key) '? key))) + +(define (use-index? pat) + (constant-symbol? (car pat))) + +(define (stream-append-delayed s1 delayed-s2) + (if (stream-null? s1) + (force delayed-s2) + (cons-stream + (stream-car s1) + (stream-append-delyed (stream-cdr s1) + delayed-s2)))) + +(define (interleave-delayed s1 delayed-s2) + (if (stream-null? s1) + (force delayed-s2) + (cons-stream + (stream-car s1) + (interleave-delayed (force delayed-s2) + (delay (stream-cdr s1)))))) + +(define (stream-flatmap proc s) + (flatten-stream (stream-map proc s))) + +(define (flatten-stream stream) + (if (stream-null? stream) + the-empty-stream + (interleave-delayed + (stream-car stream) + (delay (flatten-stream (stream-cdr stream)))))) + +(define (singleton-stream x) + (cons-stream x the-empty-stream)) + +(define (type exp) + (if (pair? exp) + (car exp) + (error "Unknown expression TYPE" exp))) + +(define (contents exp) + (if (pair? exp) + (cdr exp) + (error "Unknown expression CONTENTS" exp))) + +(define (assertion-to-be-added? exp) + (eq? (type exp) 'assert!)) + +(define (add-assertion-body exp) + (car (contents exp))) + +(define (empty-conjunction? exps) (null? exps)) +(define (first-conjunct exps) (car exps)) +(define (rest-conjucnts exps) (cdr exps)) + +(define (empty-disjunctions? exps) (null? exps)) +(define (first-disjunct exps) (car exps)) +(define (rest-disjuncts exps) (cdr exps)) + +(define (negated-query exps) (car exps)) +(define (predicate exps) (car exps)) +(define (args exps) (cdr exps)) + +(define (rule? statement) + (tagged-list? statement 'rule)) +(define (conclusion rule) + (cadr rule)) +(define (rule-body rule) + '(always-true) + (caddr rule)) + +(define (query-syntax-process exp) + (map-over-symbols expand-question-mark exp)) +(define (map-over-symbols proc exp) + (cond [(pair? exp) + (cons (map-over-symbols proc (car exp)) + (map-over-symbols proc (cdr exp)))] + [(symbol? exp) (proc exp)] + [#t exp])) +(define (expand-question-mark symbol) + (let ([chars (symbol->string symbol)]) + (if (string=? (substring chars 0 1) "?") + (list '? + (string->symbol + (substring chars 1 (string-length chars)))) + symbol))) + +(define (var? exp) + (tagged-list? exp '?)) +(define (constant-symbol? exp) + (symbol? exp)) +(define rule-counter 0) +(define (new-rule-application-id) + (set! rule-counter (+ 1 rule-counter)) + rule-counter) +(define (make-new-variable var rule-application-id) + (cons '? (cons rule-application-id (cdr var)))) +(define (contract-question-mark variable) + (string->symbol + (string-append "?" + (if (number? (cadr variable)) + (string-append (symbol->string (caddr variable)) + "-" + (number-string (cadr variable))) + (symbol->string (cadr variable)))))) + +(define (make-binding variable value) + (cons variable value)) +(define (binding-variable binding) + (car binding)) +(define (binding-value binding) + (cdr binding)) +(define (binding-in-frame variable frame) + (assoc variable frame)) +(define (extend variable value frame) + (cons (make-binding variable value) frame)) diff --git a/stream.rkt b/stream.rkt new file mode 100644 index 0000000..a7449e3 --- /dev/null +++ b/stream.rkt @@ -0,0 +1,88 @@ +#lang racket + +(provide (all-defined-out)) + +(define (memo-proc proc) + (let ([already-run? #f] + [result #f]) + (lambda () + (if (not already-run?) + (begin (set! result (proc)) + (set! already-run? #t) + result) + result)))) + +(define-syntax-rule (delay exp) + (memo-proc (lambda () exp))) + +(define (force delayed-object) + (delayed-object)) + +(define-syntax-rule (cons-my-stream a b) + (cons a (delay b))) + +(define (my-stream-car s) + (car s)) +(define (my-stream-cdr s) + (force (cdr s))) +(define (my-stream-null? s) + (null? s)) +(define the-empty-my-stream '()) + +(define (my-stream-ref s n) + (if (= n 0) + (my-stream-car s) + (my-stream-ref s (- n 1)))) + +(define (my-stream-map proc . s) + (if (my-stream-null? (car s)) + the-empty-my-stream + (cons-my-stream + (apply proc (map my-stream-car s)) + (apply my-stream-map + (cons proc (map my-stream-cdr s)))))) + +(define (my-stream-for-each proc s) + (if (my-stream-null? s) + 'done + (begin (proc (my-stream-car s)) + (my-stream-for-each proc (my-stream-cdr s))))) + +(define (my-stream-filter pred stream) + (cond [(my-stream-null? stream) the-empty-my-stream] + [(pred (my-stream-car stream)) + (cons-my-stream (my-stream-car stream) + (my-stream-filter pred (my-stream-cdr stream)))] + [#t (my-stream-filter pred (my-stream-cdr stream))])) + +(define (display-my-stream s) + (my-stream-for-each display-line s)) + +(define (display-n-my-stream s n) + (when (and (not (my-stream-null? s)) (> n 0)) + (display-line (my-stream-car s)) + (display-n-my-stream + (my-stream-cdr s) + (- n 1)))) + +(define (display-line x) + (newline) + (display x)) + +(define (stream-enumerate-interval low high) + (if (> low high) + the-empty-my-stream + (cons-my-stream low + (stream-enumerate-interval (+ low 1) high)))) + +(define (scale-my-stream stream factor) + (my-stream-map (lambda (x) (* x factor)) stream)) +(define (add-my-stream s1 s2) + (my-stream-map + s1 s2)) +(define (div-my-stream s1 s2) + (my-stream-map / s1 s2)) + +(define ones (cons-my-stream 1 ones)) +(define integers + (cons-my-stream 1 + (add-my-stream ones integers))) diff --git a/stream.rkt~ b/stream.rkt~ new file mode 100644 index 0000000..03e7adf --- /dev/null +++ b/stream.rkt~ @@ -0,0 +1,76 @@ +#lang racket + +(provide (all-defined-out)) + +(define (memo-proc proc) + (let ([already-run? #f] + [result #f]) + (lambda () + (if (not already-run?) + (begin (set! result (proc)) + (set! already-run? #t) + result) + result)))) + +(define-syntax-rule (delay exp) + (memo-proc (lambda () exp))) + +(define (force delayed-object) + (delayed-object)) + +(define-syntax-rule (cons-my-stream a b) + (cons a (delay b))) + +(define (my-stream-car s) + (car s)) +(define (my-stream-cdr s) + (force (cdr s))) +(define (my-stream-null? s) + (null? s)) +(define the-empty-my-stream '()) + +(define (my-stream-ref s n) + (if (= n 0) + (my-stream-car s) + (my-stream-ref s (- n 1)))) + +(define (my-stream-map proc . s) + (if (my-stream-null? (car s)) + the-empty-my-stream + (cons-my-stream + (apply proc (map my-stream-car s)) + (apply my-stream-map + (cons proc (map my-stream-cdr s)))))) + +(define (my-stream-for-each proc s) + (if (my-stream-null? s) + 'done + (begin (proc (my-stream-car s)) + (my-stream-for-each proc (my-stream-cdr s))))) + +(define (my-stream-filter pred stream) + (cond [(my-stream-null? stream) the-empty-my-stream] + [(pred (my-stream-car stream)) + (cons-my-stream (my-stream-car stream) + (my-stream-filter pred (my-stream-cdr stream)))] + [#t (my-stream-filter pred (my-stream-cdr stream))])) + +(define (display-my-stream s) + (my-stream-for-each display-line s)) + +(define (display-n-my-stream s n) + (when (and (not (my-stream-null? s)) (> n 0)) + (display-line (my-stream-car s)) + (display-n-my-stream + (my-stream-cdr s) + (- n 1)))) + +(define (display-line x) + (newline) + (display x)) + +(define (stream-enumerate-interval low high) + (if (> low high) + the-empty-my-stream + (cons-my-stream low + (stream-enumerate-interval (+ low 1) high)))) diff --git a/streamsingal.rkt b/streamsingal.rkt new file mode 100644 index 0000000..20fe9b5 --- /dev/null +++ b/streamsingal.rkt @@ -0,0 +1,44 @@ +#lang racket + +(require rackunit "stream.rkt") +(require rackunit "integerate-series.rkt") + +(define (integral integrand initial-value dt) + (define int + (cons-my-stream initial-value + (add-my-stream (scale-my-stream integrand dt) + int))) + int) + +(define (RC R C dt) + (lambda (i v0) + (add-my-stream (scale-my-stream i R) + (integral (scale-my-stream i (/ 1 C)) v0 dt)))) + +(define RC1 (RC 5 1 0.5)) + +(define (sign-change-detector cur last) + (cond [(and (> cur 0) (< last 0)) 1] + [(and (< cur 0) (> last 0)) -1] + [#t 0])) +(define (make-zero-crossings input-stream last-value) + (cons-my-stream + (sign-change-detector (my-stream-car input-stream) last-value) + (make-zero-crossings (my-stream-cdr input-stream) + (my-stream-car input-stream)))) +(define sense-data cosine-series) +(define zero-crossings (make-zero-crossings sense-data 0)) +(define zero-crossings2 + (my-stream-map sign-change-detector sense-data (cons-my-stream 0 sense-data))) + +(define (smooth s) + (my-stream-map (lambda (x y) (/ (+ x y) 2)) + s + (cons-my-stream 0 s))) +(define (make-zero-crossing2 input-stream) + (let ([after-smooth (smooth input-stream)]) + (my-stream-map sign-change-detector + after-smooth + (cons-my-stream 0 after-smooth)))) + + \ No newline at end of file diff --git a/streamsingal.rkt~ b/streamsingal.rkt~ new file mode 100644 index 0000000..e3839c7 --- /dev/null +++ b/streamsingal.rkt~ @@ -0,0 +1,10 @@ +#lang racket + +(require rackunit "stream.rkt") + +(define (integral integrand initial-value dt) + (define int + (cons-stream initial-value + (add-stream (scale-stream integrand dt) + int))) + int) \ No newline at end of file diff --git a/test.scm b/test.scm old mode 100644 new mode 100755 diff --git a/test_deriv.rkt b/test_deriv.rkt new file mode 100644 index 0000000..96d9cca --- /dev/null +++ b/test_deriv.rkt @@ -0,0 +1,33 @@ +#lang racket + +(require rackunit "deriv.rkt") + +(define deriv-test + (test-suite + "Test for deriv" + (check-eq? (deriv 'a 'a) 1) + (check-eq? (deriv 'a 'b) 0) + (check-eq? (deriv 3 'a) 0) + (test-case + "make-sum deriv test" + (let ([sum1 (make-sum (make-sum 'x 'y) + (make-sum 'x 2))]) + (check-eq? (deriv sum1 'x) '(sum (sum 1 . 0) sum 1 . 0)))) + (test-case + "make-product deriv test" + (let ([prod1 (make-product (make-sum 'x 'y) + (make-product 'x 2))]) + (check-eq? (deriv prod1 'x) '(product + sum + ((product x . 2) sum 1 . 0) + (sum x . y) + product + sum + (2 . 1) + x + . + 0)))) + )) + +(require rackunit/text-ui) +(run-tests deriv-test) diff --git a/test_digitele.rkt b/test_digitele.rkt new file mode 100644 index 0000000..0372399 --- /dev/null +++ b/test_digitele.rkt @@ -0,0 +1,34 @@ +#lang racket + +(require rackunit + "digitele.rkt") + +(define test_queue + (test-suite + "tests for digit ele" + (test-case + "test for empty queue" + (let ([queue (make-queue)]) + (check-true (empty-queue? queue)) + (check-exn exn:fail? (lambda () (front-queue queue)) "first front-queue should cause error") + (check-exn exn:fail? (lambda () (delete-queue! queue)) "first delete-queue should cause error") + )) + (test-case + "test for insert/delete queue" + (let ([queue (make-queue)]) + (insert-queue! queue 1) + (check-eq? (front-queue queue) 1 "front queue should be 1") + (delete-queue! queue) + (check-true (empty-queue? queue)) + (insert-queue! queue 2) + (check-eq? (front-queue queue) 2) + (insert-queue! queue 3) + (insert-queue! queue 4) + (delete-queue! queue) + (delete-queue! queue) + (check-eq? (front-queue queue) 4))) + )) + +(require rackunit/text-ui) + +(run-tests test_queue) diff --git a/test_maketable.rkt b/test_maketable.rkt new file mode 100644 index 0000000..57b84f8 --- /dev/null +++ b/test_maketable.rkt @@ -0,0 +1,37 @@ +#lang racket + +(require rackunit + "maketable.rkt") + +(define test_table + (test-suite + "test for table" + (test-case + "simple test for table operation" + (let ([table (make-table)]) + (check-false (lookup "a" table)) + (insert! "a" 2 table) + (check-eq? (lookup "a" table) 2) + (insert! "b" 3 table) + (check-eq? (lookup "b" table) 3) + (check-eq? (lookup "a" table) 2) + (insert! "a" 4 table) + (check-eq? (lookup "a" table) 4))) + (test-case + "simple test for double table operation" + (let ([table (make-table2)]) + (check-false (lookup2 "a" "b" table)) + (insert2! "a" "b" 2 table) + (check-eq? (lookup2 "a" "b" table) 2) + (check-false (lookup2 "a" "c" table)) + (check-false (lookup2 "b" "a" table)) + (insert2! "a" "c" 3 table) + (check-eq? (lookup2 "a" "b" table) 2) + (check-eq? (lookup2 "a" "c" table) 3) + (insert2! "b" "c" 4 table) + (check-eq? (lookup2 "b" "c" table) 4) + (insert2! "a" "b" 5 table) + (check-eq? (lookup2 "a" "b" table) 5))))) + +(require rackunit/text-ui) +(run-tests test_table) diff --git a/test_problems.rkt b/test_problems.rkt new file mode 100644 index 0000000..ab3b4be --- /dev/null +++ b/test_problems.rkt @@ -0,0 +1,32 @@ +#lang racket + +(require rackunit "problems.rkt") + +(test-case + "simple programs" + + ) + +(define mobile-test + (test-suite + "Test for mobile branch" + (test-case + "simple balance mobile" + (let ([mobile (make-mobile (make-branch 2 4) + (make-branch 4 2))]) + (check-true (mobile-balance mobile) "simple mobile should be balance") + (check-eq? (total-weight mobile) 6 "simple mobile should total weight 6"))) + (test-case + "simple unbalance mobile" + (let ([mobile (make-mobile (make-branch 2 7) + (make-branch 4 2))]) + (check-false (mobile-balance mobile) "simple mobile should be unbalance") + (check-eq? (total-weight mobile) 9 "simple mobile should total weight 9"))) + (test-case + "complex balance mobile" + (let ([mobile (make-mobile (make-branch 2 (make-mobile (make-branch 3 2) (make-branch 2 (make-mobile (make-branch 1 2) (make-branch 2 1))))) (make-branch 5 2))]) + (check-true (mobile-balance mobile) "complex mobile should be balance") + (check-eq? (total-weight mobile) 7 "complex mobile should total weight 11"))))) + +(require rackunit/text-ui) +(run-tests mobile-test) diff --git a/yin.rkt b/yin.rkt new file mode 100755 index 0000000..248ba68 --- /dev/null +++ b/yin.rkt @@ -0,0 +1,46 @@ +#lang racket +(require racket/match) + +(define (tree-sum exp) + (match exp + [(? number? x) x] + [(list e1 e2) + (let ([v1 (tree-sum e1)] + [v2 (tree-sum e2)]) + (+ v1 v2))])) + +(define r1-cal + (lambda (exp) + (match exp + [(? number? x) x] + [`(,op ,e1 ,e2) + (let ([v1 (r1-cal e1)] + [v2 (r1-cal e2)]) + (match op + [`+ (+ v1 v2)] + [`- (- v1 v2)] + [`* (* v1 v2)] + [`/ (/ v1 v2)]))]))) + +(define env0 '()) + +(define ext-env + (lambda (x y env) + (cons `(,x . ,y) env))) + +(define lookup + (lambda (x env) + (let ([p (assq x env)]) + (cond + [(not p) #f] + [else (cdr p)])))) + +(struct Closure (f env)) + +(define interp + (lambda (exp env) + (match exp + [(? symbol? x) + (let ([v (lookup x env)]) + (cond + ))]))) diff --git a/yin.scm b/yin.scm new file mode 100755 index 0000000..dc49018 --- /dev/null +++ b/yin.scm @@ -0,0 +1,12 @@ +(define tree-sum + (lambda (exp) + (let ((a (car exp)) + (b (cadr exp))) + (letrec ((son-tree + (lambda (x) + (if (pair? x) + (tree-sum x) + x)))) + (+ (son-tree a) + (son-tree b)))))) +(tree-sum '((1 (2 3)) (2 3)))