Advertisement
timothy235

sicp-4-3-3-amb-repl-program

Mar 25th, 2017
170
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Racket 25.51 KB | None | 0 0
  1. #lang racket
  2. (require racket/mpair)
  3. (provide (all-defined-out))
  4.  
  5. ;; This is the 4.3.3 amb repl program.  We took the 4.1.7 repl program with separate
  6. ;; syntactic analysis and modifed the analyze procedures to produce functions of
  7. ;; three parameters:  the environment, a success continuation, and a failure
  8. ;; continuation.  The driver-loop procedure controls the amb search.
  9.  
  10. ;; PROGRAM SECTIONS:
  11.  
  12. ;; 1. my-eval and analyze
  13. ;; 2. amb
  14. ;; 3. self-evaluating expressions, variables, and quotations
  15. ;; 4. definition and assignment
  16. ;; 5. lambdas, procedures and applications
  17. ;; 6. sequences and begin expressions
  18. ;; 7. boolean expressions
  19. ;; 8. if and cond expressions
  20. ;; 9. let, let*, named-let, and letrec
  21. ;; 10. environment and frames
  22. ;; 11. primitive procedures and the global environment
  23. ;; 12. repl operations
  24. ;; 13. helper functions like my-require
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;; 1. MY-EVAL AND ANALYZE  ;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (define (ambeval expr env succeed fail)
  31.   ((analyze expr) env succeed fail))
  32.  
  33. (define (analyze expr)
  34.   (cond [(self-evaluating? expr)
  35.          (analyze-self-evaluating expr)]
  36.         [(amb? expr) (analyze-amb expr)] ; changed
  37.         [(quoted? expr) (analyze-quoted expr)]
  38.         [(variable? expr) (analyze-variable expr)]
  39.         [(assignment? expr) (analyze-assignment expr)]
  40.         [(definition? expr) (analyze-definition expr)]
  41.         [(if? expr) (analyze-if expr)]
  42.         [(lambda? expr) (analyze-lambda expr)]
  43.         [(begin? expr) (analyze-sequence (begin-actions expr))]
  44.         [(cond? expr) (analyze (cond->if expr))]
  45.         [(and? expr) (analyze (and->if expr))]
  46.         [(or? expr) (analyze (or->if expr))]
  47.         [(let? expr) (analyze (let->combination expr))]
  48.         [(let*? expr) (analyze (let*->nested-lets expr))]
  49.         [(named-let? expr) (analyze (named-let->sequence expr))]
  50.         [(letrec? expr) (analyze (letrec->simultaneous-lets expr))]
  51.         [(application? expr) (analyze-application expr)]
  52.         [else (error "Unknown expression type -- ANALYZE" expr)]))
  53.  
  54. ;;;;;;;;;;;;
  55. ;; 2. AMB ;;
  56. ;;;;;;;;;;;;
  57.  
  58. (define (amb? expr) (tagged-list? expr 'amb))
  59. (define (amb-choices expr) (rest expr))
  60.  
  61. ;; succeed and fail are continuations.  A success continuation is a function of two
  62. ;; arguments, the value just obtained and a fail continuation used to backtrack.  A
  63. ;; fail continuation is a function of no arguments.
  64.  
  65. ;; analyze will return an execution procedure which will look like:
  66. ;; (lambda (env succeed fail)
  67.   ;; ;; succeed is (lambda (value fail) ...)
  68.   ;; ;; fail is (lambda () ...)
  69.   ;; ...)
  70.  
  71. (define (analyze-amb expr)
  72.   (define cprocs (map analyze (amb-choices expr)))
  73.   (lambda (env succeed fail)
  74.     (define (try-next choices)
  75.       (if (empty? choices)
  76.         (fail)
  77.         ((first choices) env
  78.                          succeed
  79.                          (lambda ()
  80.                            (try-next (rest choices))))))
  81.     (try-next cprocs)))
  82.  
  83. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  84. ;; 3. SELF-EVALUATING EXPRESSIONS, VARIABLES, AND QUOTATIONS  ;;
  85. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86.  
  87. (define (tagged-list? expr tag)
  88.   (if (pair? expr)
  89.     (eq? (first expr) tag)
  90.     false))
  91. (define *reserved-symbols*
  92.   (list
  93.     '*unassigned*
  94.     ))
  95. ;; Only numbers, strings, and reserved symbols are self-evaluating.
  96. (define (self-evaluating? expr)
  97.   (or (number? expr)
  98.       (string? expr)
  99.       (member expr *reserved-symbols*)))
  100. (define (analyze-self-evaluating expr) ; changed
  101.   (lambda (env succeed fail)
  102.     (succeed expr fail)))
  103. (define (variable? expr)
  104.   (and (symbol? expr)
  105.        (not (member expr *reserved-symbols*))))
  106. (define (analyze-variable expr) ; changed
  107.   (lambda (env succeed fail)
  108.     (succeed (lookup-variable-value expr env)
  109.              fail)))
  110. ;; Quotations have the form:  (quote <text-of-quotation>)
  111. (define (quoted? expr)
  112.   (tagged-list? expr 'quote))
  113. (define (text-of-quotation expr)
  114.   (second expr))
  115. (define (analyze-quoted expr) ; changed
  116.   (define qval (text-of-quotation expr))
  117.   (lambda (env succeed fail)
  118.     (succeed qval fail)))
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ;; 4. DEFINITION AND ASSIGNMENT  ;;
  122. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  123.  
  124. ;; Variable definitions have the form:  (define <var> <value>)
  125.  
  126. ;; Procedure definitions have the form:
  127. ;; (define (<var> <parameter-1> ... <parameter-n>) <body>)
  128. ;; which is equivalent to:
  129. ;; (define <var> (lambda (<parameter-1> ... <parameter-n>) <body>))
  130.  
  131. (define (definition? expr) (tagged-list? expr 'define))
  132. (define (definition-variable expr)
  133.   (if (symbol? (second expr))
  134.     (second expr)
  135.     (first (second expr))))
  136. (define (definition-value expr)
  137.   (if (symbol? (second expr))
  138.     (third expr)
  139.     (make-lambda (rest (second expr)) ; formal parameters
  140.                  (drop expr 2))))
  141. (define (analyze-definition expr) ; changed
  142.   (define var (definition-variable expr))
  143.   (define vproc (analyze (definition-value expr)))
  144.   (lambda (env succeed fail)
  145.     (vproc env
  146.            (lambda (val fail2)
  147.              (define-variable! var val env)
  148.              (succeed 'ok fail2))
  149.            fail)))
  150.  
  151. ;; Assignments have the form:  (set! <var> <value>)
  152. (define (assignment? expr)
  153.   (tagged-list? expr 'set!))
  154. (define (assignment-variable expr) (second expr))
  155. (define (assignment-value expr) (third expr))
  156. ; must remember old value to restore if branch later fails
  157. (define (analyze-assignment expr) ; changed
  158.   (define var (assignment-variable expr))
  159.   (define vproc (analyze (assignment-value expr)))
  160.   (lambda (env succeed fail)
  161.     (vproc env
  162.            (lambda (val fail2)      ; *1*
  163.              (define old-value (lookup-variable-value var env))
  164.              (set-variable-value! var val env)
  165.              (succeed 'ok
  166.                       (lambda ()    ; *2*
  167.                         (set-variable-value! var old-value env)
  168.                         (fail2))))
  169.            fail)))
  170.  
  171.  
  172. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  173. ;; 5. LAMBDAS, PROCEDURES AND APPLICATIONS  ;;
  174. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  175.  
  176. ;; Lambda expressions have the form:
  177. ;; (lambda (<parameters>) <body>)
  178. (define (lambda? expr) (tagged-list? expr 'lambda))
  179. (define (lambda-parameters expr) (second expr))
  180. (define (lambda-body expr)
  181.   (drop expr 2))
  182. (define (make-lambda parameters body)
  183.   (cons 'lambda (cons parameters body)))
  184. (define (scan-out-defines body)
  185.   (define defines (filter definition? body))
  186.   (cond [(empty? defines) body]
  187.         [else
  188.           (define rest-of-body (filter-not definition? body))
  189.           (define vars (map definition-variable defines))
  190.           (define vals (map definition-value defines))
  191.           (define bindings
  192.             (for/list ([v vars])
  193.                       (list v '*unassigned*)))
  194.           (define assigns
  195.             (for/list ([v vars]
  196.                        [e vals])
  197.                       (list 'set! v e)))
  198.           ; a body is a list of expressions
  199.           (list
  200.             (make-let
  201.               bindings
  202.               (append assigns rest-of-body)))]))
  203. (define (analyze-lambda expr) ; changed
  204.   (define vars (lambda-parameters expr))
  205.   (define bproc (analyze-sequence (scan-out-defines (lambda-body expr))))
  206.   (lambda (env succeed fail)
  207.     (succeed (make-procedure vars bproc env)
  208.              fail)))
  209.  
  210. ;; Procedures:
  211. (define (compound-procedure? p)
  212.   (tagged-list? p 'procedure))
  213. (define (make-procedure parameters body env)
  214.   (list 'procedure parameters body env))
  215. (define (procedure-parameters p) (second p))
  216. (define (procedure-body p) (third p))
  217. (define (procedure-environment p) (fourth p))
  218.  
  219. ;; Procedure applications have the from:
  220. ;; (<var> <parameter> ...)
  221. (define (application? expr) (pair? expr))
  222. (define (operator expr) (first expr))
  223. (define (operands expr) (rest expr))
  224. (define (no-operands? ops) (empty? ops))
  225. (define (first-operand ops) (first ops))
  226. (define (rest-operands ops) (rest ops))
  227. (define (analyze-application expr) ; changed
  228.   (define fproc (analyze (operator expr)))
  229.   (define aprocs (map analyze (operands expr)))
  230.   (lambda (env succeed fail)
  231.     (fproc env
  232.            (lambda (proc fail2)
  233.              (get-args aprocs
  234.                        env
  235.                        (lambda (args fail3)
  236.                          (execute-application
  237.                            proc args succeed fail3))
  238.                        fail2))
  239.            fail)))
  240.  
  241. ;; "In get-args, notice how cdring down the list of aproc execution procedures and
  242. ;; consing up the resulting list of args is accomplished by calling each aproc in the
  243. ;; list with a success continuation that recursively calls get-args. Each of these
  244. ;; recursive calls to get-args has a success continuation whose value is the cons of
  245. ;; the newly obtained argument onto the list of accumulated arguments:"
  246.  
  247. (define (get-args aprocs env succeed fail) ; changed, new
  248.   (if (empty? aprocs)
  249.     (succeed empty fail)
  250.     ((first aprocs) env
  251.                     ; success continuation for this aproc
  252.                     (lambda (arg fail2)
  253.                       (get-args (rest aprocs)
  254.                                 env
  255.                                 ; success continuation for recursive call to
  256.                                 ; get-args
  257.                                 (lambda (args fail3)
  258.                                   (succeed (cons arg args)
  259.                                            fail3))
  260.                                 fail2))
  261.                     fail)))
  262. (define (execute-application proc args succeed fail) ; changed
  263.   (cond [(primitive-procedure? proc)
  264.          (succeed (apply-primitive-procedure proc args)
  265.                   fail)]
  266.         [(compound-procedure? proc)
  267.          ((procedure-body proc)
  268.           (extend-environment (procedure-parameters proc)
  269.                               args
  270.                               (procedure-environment proc))
  271.           succeed
  272.           fail)]
  273.         [else
  274.           (error "Unknown procedure type -- EXECUTE-APPLICATION" proc)]))
  275.  
  276. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  277. ;; 6. SEQUENCES AND BEGIN EXPRESSIONS  ;;
  278. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  279.  
  280. ;; Begin has the form:  (begin <actions>)
  281. (define (begin? expr) (tagged-list? expr 'begin))
  282. (define (begin-actions expr) (rest expr))
  283. (define (last-exp? seq) (empty? (rest seq)))
  284. (define (first-exp seq) (first seq))
  285. (define (rest-exps seq) (rest seq))
  286. (define (sequence->exp seq)
  287.   (cond [(empty? seq) seq]
  288.         [(last-exp? seq) (first-exp seq)]
  289.         [else (make-begin seq)]))
  290. (define (make-begin seq) (cons 'begin seq))
  291. (define (analyze-sequence exprs) ; changed
  292.   (define (sequentially a b)
  293.     (lambda (env succeed fail)
  294.       (a env
  295.          ; success continuation for calling a
  296.          (lambda (a-value fail2)
  297.            (b env succeed fail2))
  298.          ; failure continuation for calling a
  299.          fail)))
  300.   (define (loop first-proc rest-procs)
  301.     (if (empty? rest-procs)
  302.       first-proc
  303.       (loop (sequentially first-proc (first rest-procs))
  304.             (rest rest-procs))))
  305.   (define procs (map analyze exprs))
  306.   (if (empty? procs) (error "Empty sequence -- ANALYZE")
  307.     (loop (first procs) (rest procs))))
  308.  
  309. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  310. ;; 7. BOOLEAN EXPRESSIONS  ;;
  311. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  312.  
  313. (define (true? x) (not (false? x)))
  314. (define (and? expr) (tagged-list? expr 'and))
  315. (define (and-operands expr) (rest expr))
  316. (define (make-and sequence) (cons 'and sequence))
  317. (define (and->if expr)
  318.   (expand-and-operands (and-operands expr)))
  319. (define (expand-and-operands ops)
  320.   (cond [(empty? ops) 'true]
  321.         [else
  322.           (define first-op (first ops))
  323.           (define rest-ops (rest ops))
  324.           (cond [(empty? rest-ops) first-op]
  325.                 [else
  326.                   (make-if first-op
  327.                            (and->if (make-and rest-ops))
  328.                            'false)])]))
  329. (define (or? expr) (tagged-list? expr 'or))
  330. (define (or-operands expr) (rest expr))
  331. (define (make-or sequence) (cons 'or sequence))
  332. (define (or->if expr)
  333.   (expand-or-operands (or-operands expr)))
  334. (define (expand-or-operands ops)
  335.   (cond [(empty? ops) 'false] ; (or) should return false
  336.         [else
  337.           (define first-op (first ops))
  338.           (define rest-ops (rest ops))
  339.           (cond [(empty? rest-ops) first-op] ; (or x) should return x
  340.                 [else
  341.                   (make-if first-op
  342.                            first-op ; inefficient second evaluation
  343.                            (or->if (make-or rest-ops)))])]))
  344.  
  345. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  346. ;; 8. IF AND COND EXPRESSIONS  ;;
  347. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  348.  
  349. ;; Conditionals have the form:  (if <predicate> <consequent> <alternative>)
  350. ;; If no alternative, use false.
  351. (define (if? expr) (tagged-list? expr 'if))
  352. (define (if-predicate expr) (second expr))
  353. (define (if-consequent expr) (third expr))
  354. (define (if-alternative expr)
  355.   (if (not (empty? (drop expr 3)))
  356.     (fourth expr)
  357.     'false))
  358. (define (make-if predicate consequent alternative)
  359.   (list 'if predicate consequent alternative))
  360. (define (analyze-if expr) ; changed
  361.   (define pproc (analyze (if-predicate expr)))
  362.   (define cproc (analyze (if-consequent expr)))
  363.   (define aproc (analyze (if-alternative expr)))
  364.   (lambda (env succeed fail)
  365.     (pproc env
  366.            ; success continuation for evaluating the predicate
  367.            ; to obtain pred-value
  368.            (lambda (pred-value fail2)
  369.              (if pred-value ; (true? pred-value)
  370.                (cproc env succeed fail2)
  371.                (aproc env succeed fail2)))
  372.            ; failure continuation for evaluating the predicate
  373.            fail)))
  374.  
  375. ;; Cond has the form:
  376. ;; (cond ((<predicate> <actions>)
  377.        ;; (else <actions>))) ; if no else, assume (else false) clause
  378. (define (cond? expr) (tagged-list? expr 'cond))
  379. (define (cond-clauses expr) (rest expr))
  380. ;; regular cond clause
  381. (define (cond-predicate clause) (first clause))
  382. (define (cond-actions clause) (rest clause))
  383. ;; alternate test clause
  384. (define (cond-alternate-clause? clause)
  385.   (eq? (second clause) '=>))
  386. (define (cond-test clause) (first clause))
  387. (define (cond-recipient clause) (third clause))
  388. ;; else clause
  389. (define (cond-else-clause? clause)
  390.   (eq? (cond-predicate clause) 'else))
  391. ;; derive cond from if
  392. (define (cond->if expr)
  393.   (expand-clauses (cond-clauses expr)))
  394. (define (expand-clauses clauses)
  395.   (cond [(empty? clauses) 'false] ; no else clause
  396.         [else
  397.           (define first-clause (first clauses))
  398.           (define rest-clauses (rest clauses))
  399.           (cond [(cond-else-clause? first-clause)
  400.                  (if (empty? rest-clauses)
  401.                    (sequence->exp (cond-actions first-clause))
  402.                    (error "ELSE clause is not last -- COND->IF" clauses))]
  403.                 [(cond-alternate-clause? first-clause)
  404.                  (define test (cond-test first-clause)) ; gets evaluated twice
  405.                  (make-if test
  406.                           (list (cond-recipient first-clause)
  407.                                 test)
  408.                           (expand-clauses rest-clauses))]
  409.                 [else
  410.                   (make-if (cond-predicate first-clause)
  411.                            (sequence->exp (cond-actions first-clause))
  412.                            (expand-clauses rest-clauses))])]))
  413.  
  414. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  415. ;; 9. LET, LET*, NAMED-LET, AND LETREC  ;;
  416. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  417.  
  418. ;; Let has the form:  (let (<bindings>) <body>)
  419. (define (let? expr)
  420.   (and (tagged-list? expr 'let)
  421.        (list? (second expr))))
  422. (define (let-bindings expr) (second expr))
  423. (define (let-parameters expr) (map first (let-bindings expr)))
  424. (define (let-expressions expr) (map second (let-bindings expr)))
  425. (define (let-body expr) (drop expr 2))
  426. (define (let->combination expr)
  427.   (cond [(empty? (let-bindings expr)) ; do not unnecessarily lambda wrap
  428.          (sequence->exp (let-body expr))]
  429.         [else
  430.           (cons (make-lambda (let-parameters expr)
  431.                              (let-body expr))
  432.                 (let-expressions expr))]))
  433. (define (make-let bindings body)
  434.   (cons 'let (cons bindings body)))
  435.  
  436. ;; Let* has the same form as let, but bindings are sequential.
  437. (define (let*? expr) (tagged-list? expr 'let*))
  438. (define (let*-bindings expr) (second expr))
  439. (define (let*-body expr) (drop expr 2))
  440. (define (make-let* bindings body)
  441.   (cons 'let* (cons bindings body)))
  442. (define (let*->nested-lets expr)
  443.   (define bindings (let*-bindings expr))
  444.   (cond [(empty? bindings)
  445.          (sequence->exp (let-body expr))]
  446.         [else
  447.           (list 'let
  448.                 (list (first bindings))
  449.                 (let*->nested-lets
  450.                   (make-let* (rest bindings)
  451.                              (let-body expr))))]))
  452.  
  453. ;; Named-let has the form:  (let <name> (<bindings>) <body>)
  454. (define (named-let? expr)
  455.   (and (tagged-list? expr 'let)
  456.        (not (list? (second expr)))))
  457. (define (named-let-name expr) (second expr))
  458. (define (named-let-bindings expr) (third expr))
  459. (define (named-let-parameters expr) (map first (named-let-bindings expr)))
  460. (define (named-let-expressions expr) (map second (named-let-bindings expr)))
  461. (define (named-let-body expr) (drop expr 3))
  462. (define (named-let->sequence expr)
  463.   (define bindings (named-let-bindings expr))
  464.   (cond [(empty? bindings)
  465.          (sequence->exp (named-let-body expr))]
  466.         [else
  467.           (list 'begin
  468.                 (cons 'define ; first define the named function
  469.                       (cons (cons (named-let-name expr)
  470.                                   (named-let-parameters expr))
  471.                             (named-let-body expr)))
  472.                 (cons (named-let-name expr) ; then apply it to the expressions
  473.                       (named-let-expressions expr)))]))
  474.  
  475. ;; Letrec has the same form as let, but letrec parameters are first bound to
  476. ;; '*unassigned* and then set! to their values to mimic simultaneous definitions.
  477. (define (letrec? expr) (tagged-list? expr 'letrec))
  478. (define (letrec-bindings expr) (second expr))
  479. (define (letrec-body expr) (drop expr 2))
  480. (define (letrec->simultaneous-lets expr)
  481.   (define bindings (letrec-bindings expr))
  482.   (cond [(empty? bindings)
  483.          (letrec-body expr)]
  484.         [else
  485.           (define vars (map first bindings))
  486.           (define vals (map second bindings))
  487.           (define new-bindings
  488.             (for/list ([v vars])
  489.                       (list v '*unassigned*)))
  490.           (define assigns
  491.             (for/list ([v vars]
  492.                        [e vals])
  493.                       (list 'set! v e)))
  494.           (make-let
  495.             new-bindings
  496.             (append assigns (letrec-body expr)))]))
  497.  
  498. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  499. ;; 10. ENVIRONMENT AND FRAMES  ;;
  500. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  501.  
  502. ;; An environment is a mutable list of frames.  The enclosing environment is the mcdr
  503. ;; of the list.  A frame is a mutable list of bindings with a 'frame header.  A
  504. ;; binding is a var-val pair ie (mcons var val).
  505.  
  506. ;; Environments support four procedures:
  507.     ;; lookup-variable-value
  508.     ;; extend-environment
  509.     ;; define-variable
  510.     ;; set-variable-value
  511.  
  512. ;; Two helper functions support the environment procedures:
  513.     ;; find-binding-in-frame
  514.     ;; find-binding-in-environment
  515.  
  516. (define (enclosing-environment env) (mcdr env))
  517. (define (first-frame env) (mcar env))
  518. (define the-empty-environment empty)
  519. (define the-empty-frame (mlist 'frame))
  520. (define (empty-frame? frame)
  521.   (empty? (frame-bindings frame)))
  522. (define (make-frame vars vals)
  523.   (mcons 'frame
  524.          (mmap mcons
  525.                (list->mlist vars)
  526.                (list->mlist vals))))
  527. (define (frame-bindings frame) (mcdr frame))
  528. (define (frame-variables frame) (mmap mcar (frame-bindings frame)))
  529. (define (frame-values frame) (mmap mcdr (frame-bindings frame)))
  530.  
  531. (define (binding-variable binding) (mcar binding))
  532. (define (binding-value binding) (mcdr binding))
  533. (define (set-value! binding val) (set-mcdr! binding val))
  534. (define (add-binding-to-frame! var val frame)
  535.   (mappend! frame (mlist (mcons var val))))
  536. (define (find-binding-in-frame var frame)
  537.   ; Return the var-val pair if present else false.
  538.   (define (loop bindings)
  539.     (cond [(empty? bindings) false]
  540.           [else
  541.             (define b (mcar bindings))
  542.             (if (eq? var (binding-variable b))
  543.               b
  544.               (loop (mcdr bindings)))]))
  545.   (loop (frame-bindings frame)))
  546. (define (find-binding-in-env var env)
  547.   ; Return the closest binding for var if present else false.
  548.   (cond [(eq? env the-empty-environment) false]
  549.         [else
  550.           (define b (find-binding-in-frame var (first-frame env)))
  551.           (or b (find-binding-in-env var (enclosing-environment env)))]))
  552.  
  553. (define (lookup-variable-value var env)
  554.   (define b (find-binding-in-env var env))
  555.   (if (false? b)
  556.     (error "Unbound variable" var)
  557.     (binding-value b)))
  558. (define (extend-environment vars vals base-env)
  559.   (cond [(= (length vars) (length vals))
  560.          (mcons (make-frame vars vals) base-env)]
  561.         [else
  562.           (if (< (length vars) (length vals))
  563.             (error "Too many arguments supplied" vars vals)
  564.             (error "Too few arguments supplied" vars vals))]))
  565. (define (define-variable! var val env)
  566.   (define frame (first-frame env))
  567.   (define b (find-binding-in-frame var frame))
  568.   (if b
  569.     (set-value! b val)
  570.     (add-binding-to-frame! var val frame)))
  571. (define (set-variable-value! var val env)
  572.   (define b (find-binding-in-env var env))
  573.   (if b
  574.     (set-value! b val)
  575.     (error "Unbound variable -- SET!" var)))
  576.  
  577. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  578. ;; 11. PRIMITIVE PROCEDURES AND THE GLOBAL ENVIRONMENT  ;;
  579. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  580.  
  581. (define primitive-procedures
  582.   (list
  583.     ; boolean
  584.     (list 'not not)
  585.     (list 'false? false?)
  586.     (list 'true? (lambda (x) (not (false? x))))
  587.     ; symbol
  588.     (list 'eq? eq?)
  589.     ; list
  590.     (list 'cons cons)
  591.     (list 'car car)
  592.     (list 'cdr cdr)
  593.     (list 'list list)
  594.     (list 'member member)
  595.     (list 'empty? empty?)
  596.     (list 'first first)
  597.     (list 'rest rest)
  598.     (list 'second second)
  599.     ; number
  600.     (list '+ +)
  601.     (list '* *)
  602.     (list '- -)
  603.     (list '< <)
  604.     (list '> >)
  605.     (list '<= <=)
  606.     (list '>= >=)
  607.     (list '= =)
  608.     (list 'abs abs)
  609.     ))
  610. (define (primitive-procedure? proc)
  611.   (tagged-list? proc 'primitive))
  612. (define (primitive-implementation proc)
  613.   (second proc))
  614. (define (primitive-procedure-names)
  615.   (map first primitive-procedures))
  616. (define (primitive-procedure-objects)
  617.   (map (lambda (proc) (list 'primitive (second proc)))
  618.        primitive-procedures))
  619. (define apply-in-underlying-scheme apply)
  620. ;; The metacircular evaluator's apply is my-apply.
  621. (define (apply-primitive-procedure proc args)
  622.   (apply-in-underlying-scheme
  623.     (primitive-implementation proc) args))
  624.  
  625. (define (setup-environment)
  626.   (define initial-env
  627.     (extend-environment (primitive-procedure-names)
  628.                         (primitive-procedure-objects)
  629.                         the-empty-environment))
  630.   (define-variable! 'true true initial-env)
  631.   (define-variable! 'false false initial-env)
  632.   initial-env)
  633. (define the-global-environment (setup-environment))
  634.  
  635. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  636. ;; 12. REPL OPERATIONS  ;;
  637. ;;;;;;;;;;;;;;;;;;;;;;;;;;
  638.  
  639. (define input-prompt ";;; Amb-Eval input:")
  640. (define output-prompt ";;; Amb-Eval value:")
  641. (define (driver-loop) ; changed
  642.   (define (internal-loop try-again)
  643.     (prompt-for-input input-prompt)
  644.     (define input (read))
  645.     (cond [(eq? input 'try-again) (try-again)]
  646.           [else
  647.             (displayln ";;; Starting a new problem ")
  648.             (ambeval input
  649.                      the-global-environment
  650.                      ; ambeval success
  651.                      (lambda (val next-alternative)
  652.                        (announce-output output-prompt)
  653.                        (user-print val)
  654.                        (internal-loop next-alternative))
  655.                      ; ambeval failure
  656.                      (lambda ()
  657.                        (announce-output
  658.                          ";;; There are no more values of")
  659.                        (user-print input)
  660.                        (driver-loop)))]))
  661.   (internal-loop
  662.     (lambda ()
  663.       (displayln ";;; There is no current problem")
  664.       (driver-loop))))
  665. (define prompt-for-input displayln)
  666. (define announce-output displayln)
  667. (define (user-print object)
  668.   (if (compound-procedure? object)
  669.     (displayln (list 'compound-procedure
  670.                    (procedure-parameters object)
  671.                    (procedure-body object)
  672.                    '<procedure-env>))
  673.     (displayln object)))
  674.  
  675. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  676. ;; 13. INSTALL SOME HELPER FUNCTIONS ;;
  677. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  678.  
  679. (define helpers
  680.   (list
  681.     '(define (my-require p)
  682.        (if (not p)
  683.          (amb)
  684.         true))
  685.     '(define (distinct? items)
  686.        (cond [(empty? items) true]
  687.              [(empty? (cdr items)) true]
  688.              [(member (car items) (cdr items)) false]
  689.              [else (distinct? (cdr items))]))
  690.     '(define (an-element-of items)
  691.        (my-require (not (empty? items)))
  692.        (amb (car items) (an-element-of (cdr items))))
  693.     '(define (an-integer-starting-from n)
  694.        (amb n (an-integer-starting-from (+ n 1))))
  695.     ))
  696. (define (install-helpers)
  697.   (define (install expr)
  698.     (ambeval expr
  699.              the-global-environment
  700.              (lambda (value fail) value)
  701.              (lambda () 'failed)))
  702.   (for ([e helpers])
  703.     (install e))
  704.   'helper-functions-installed)
  705. (install-helpers)
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement