diff --git a/ex-4_45-xx.scm b/ex-4_45-xx.scm index 5047814..2ecfdf4 100644 --- a/ex-4_45-xx.scm +++ b/ex-4_45-xx.scm @@ -1,27 +1,38 @@ (load "util.scm") -(load "misc/amb.scm") +(load "misc/sicp-ambeval.scm") + +(define the-global-environment (setup-environment)) +(define result '()) + +(define (amball exp) + (set! result '()) ; reset result + (ambeval exp + the-global-environment + (lambda (value next) + (set! result (cons value result)) + (next)) + (lambda () result)) + (set! result (reverse result)) + result) + +(amball '(begin + +(define (require p) + (if (not p) (amb))) (define nouns '(noun student professor cat class)) (define verbs '(verb studies lectures eats sleeps)) (define articles '(article the a)) -(define *unparsed* '()) - -; By default mit-scheme evaluates the list elements from last to first element. -; That means with the parse-implementation in the book the later part of a -; phrase is evaluated first which does not yield any results. To force the -; correct order we use a let expression and then built the return list from the -; let variables. - (define (parse-sentence) - (let* ((noun-phrase (parse-noun-phrase)) - (verb-phrase (parse-word verbs))) - (list 'sentence noun-phrase verb-phrase))) + (list 'sentence + (parse-noun-phrase) + (parse-word verbs))) (define (parse-noun-phrase) - (let* ((article-phrase (parse-word articles)) - (noun-phrase (parse-word nouns))) - (list 'noun-phrase article-phrase noun-phrase))) + (list 'noun-phrase + (parse-word articles) + (parse-word nouns))) (define (parse-word word-list) (require (not (null? *unparsed*))) @@ -30,19 +41,156 @@ (set! *unparsed* (cdr *unparsed*)) (list (car word-list) found-word))) +(define *unparsed* '()) (define (parse input) (set! *unparsed* input) (let ((sent (parse-sentence))) (require (null? *unparsed*)) sent)) -(display "\nex-4.45 - parse-sentence\n") +(define prepositions '(prep for to in by with)) -(my-assert (parse '(the cat eats)) - '(sentence (noun-phrase (article the) (noun cat)) (verb eats))) +(define (parse-prepositional-phrase) + (list 'prep-phrase + (parse-word prepositions) + (parse-noun-phrase))) -;'(The professor lectures to the student in the class with the cat) +(define (parse-sentence) + (list 'sentence + (parse-noun-phrase) + (parse-verb-phrase))) -(display "\nex-4.46\n") +(define (parse-verb-phrase) + (define (maybe-extend verb-phrase) + (amb verb-phrase + (maybe-extend (list 'verb-phrase + verb-phrase + (parse-prepositional-phrase))))) + (maybe-extend (parse-word verbs))) +(define (parse-simple-noun-phrase) + (list 'simple-noun-phrase + (parse-word articles) + (parse-word nouns))) +(define (parse-noun-phrase) + (define (maybe-extend noun-phrase) + (amb noun-phrase + (maybe-extend (list 'noun-phrase + noun-phrase + (parse-prepositional-phrase))))) + (maybe-extend (parse-simple-noun-phrase))) + +(parse '(the professor lectures to the student with the cat)) +)) + +;'The professor lectures to the student in the class with the cat.' +(assert + (first result) + '(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb-phrase + (verb lectures) + (prep-phrase (prep to) + (simple-noun-phrase + (article the) (noun student)))) + (prep-phrase (prep with) + (simple-noun-phrase + (article the) (noun cat)))))) +(assert + (second result) + '(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb lectures) + (prep-phrase (prep to) + (noun-phrase + (simple-noun-phrase + (article the) (noun student)) + (prep-phrase (prep with) + (simple-noun-phrase + (article the) (noun cat)))))))) + +(display "\nex-4.45 - sentence-meanings\n") + +(amball '(parse '(The professor lectures to the student in the class with the cat))) +(assert (length result) 5) + +'(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb-phrase + (verb-phrase + (verb lectures) + (prep-phrase + (prep to) (simple-noun-phrase (article the) (noun student)))) + (prep-phrase + (prep in) (simple-noun-phrase (article the) (noun class)))) + (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat))))) + +; The professor lectures (to the student) in the class with the cat. + +'(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb-phrase + (verb lectures) + (prep-phrase (prep to) (simple-noun-phrase (article the) (noun student)))) + (prep-phrase + (prep in) + (noun-phrase + (simple-noun-phrase (article the) (noun class)) + (prep-phrase (prep with) + (simple-noun-phrase (article the) (noun cat))))))) + +; The professor lectures to the student (in the class with the cat). + +'(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb-phrase + (verb lectures) + (prep-phrase + (prep to) + (noun-phrase + (simple-noun-phrase (article the) (noun student)) + (prep-phrase (prep in) (simple-noun-phrase (article the) (noun class)))))) + (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat))))) + +; The professor lectures (to the student in the class) with the cat. + +'(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb lectures) + (prep-phrase + (prep to) + (noun-phrase + (noun-phrase + (simple-noun-phrase (article the) (noun student)) + (prep-phrase (prep in) + (simple-noun-phrase (article the) (noun class)))) + (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat))))))) + +; The professor lectures ((to the student in the class) with the cat). + +'(sentence + (simple-noun-phrase (article the) (noun professor)) + (verb-phrase + (verb lectures) + (prep-phrase + (prep to) + (noun-phrase + (simple-noun-phrase (article the) (noun student)) + (prep-phrase + (prep in) + (noun-phrase + (simple-noun-phrase (article the) (noun class)) + (prep-phrase (prep with) (simple-noun-phrase (article the) (noun cat))))))))) + +; The professor lectures (to the student (in the class with the cat)). + +(display "[answered]\n") + +(display "\nex-4.46 - evaluation-order\n") diff --git a/misc/sicp-ambeval.scm b/misc/sicp-ambeval.scm new file mode 100644 index 0000000..3fd53da --- /dev/null +++ b/misc/sicp-ambeval.scm @@ -0,0 +1,628 @@ +; COPIED FROM: https://mitpress.mit.edu/sites/default/files/sicp/code/index.html + +;;;;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) + ((eq? exp #t) true) + ((eq? exp #f) 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 + + +;;;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)) + ((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 (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 (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 + +(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 'display display) + (list '+ +) + (list '- -) + (list '* *) + (list '= =) + (list '> >) + (list '>= >=) + (list '<= <=) + (list 'abs abs) + (list 'remainder remainder) + (list 'integer? integer?) + (list 'sqrt sqrt) + (list 'eq? eq?) +;; more primitives + )) + + +'AMB-EVALUATOR-LOADED