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

#lang racket
(require racket/mpair
         math/number-theory) ; for prime?
(provide (all-defined-out))

;; This is the exercise 4.54 amb repl program.  It is the same as the 4.3.3 amb repl
;; program, except that we have implemented permanent-set! from exercise 4.51,
;; if-fail from exercise 4.52, and my-require is now a syntactic form and not a
;; defined function.

;; PROGRAM SECTIONS:

;; 1. my-eval and analyze
;; 2. amb and my-require
;; 3. self-evaluating expressions, variables, and quotations
;; 4. definition and assignment
;; 5. lambdas, procedures and applications
;; 6. sequences and begin expressions
;; 7. boolean expressions
;; 8. if and cond expressions
;; 9. let, let*, named-let, and letrec
;; 10. environment and frames
;; 11. primitive procedures and the global environment
;; 12. repl operations
;; 13. helper functions

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 1. MY-EVAL AND ANALYZE  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ambeval expr env succeed fail)
  ((analyze expr) env succeed fail))

(define (analyze expr)
  (cond [(self-evaluating? expr)
         (analyze-self-evaluating expr)]
        [(amb? expr) (analyze-amb expr)]
        [(my-require? expr) (analyze-my-require expr)]
        [(quoted? expr) (analyze-quoted expr)]
        [(variable? expr) (analyze-variable expr)]
        [(assignment? expr) (analyze-assignment expr)]
        [(permanent-assignment? expr) (analyze-permanent-assignment expr)]
        [(definition? expr) (analyze-definition expr)]
        [(if? expr) (analyze-if expr)]
        [(if-fail? expr) (analyze-if-fail expr)]
        [(lambda? expr) (analyze-lambda expr)]
        [(begin? expr) (analyze-sequence (begin-actions expr))]
        [(cond? expr) (analyze (cond->if expr))]
        [(and? expr) (analyze (and->if expr))]
        [(or? expr) (analyze (or->if expr))]
        [(let? expr) (analyze (let->combination expr))]
        [(let*? expr) (analyze (let*->nested-lets expr))]
        [(named-let? expr) (analyze (named-let->sequence expr))]
        [(letrec? expr) (analyze (letrec->simultaneous-lets expr))]
        [(application? expr) (analyze-application expr)]
        [else (error "Unknown expression type -- ANALYZE" expr)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 2. AMB AND MY-REQUIRE ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (amb? expr) (tagged-list? expr 'amb))
(define (amb-choices expr) (rest expr))

;; succeed and fail are continuations.  A success continuation is a function of two
;; arguments, the value just obtained and a fail continuation used to backtrack.  A
;; fail continuation is a function of no arguments.

;; analyze will return an execution procedure which will look like:
;; (lambda (env succeed fail)
  ;; ;; succeed is (lambda (value fail) ...)
  ;; ;; fail is (lambda () ...)
  ;; ...)
(define (analyze-amb expr)
  (define cprocs (map analyze (amb-choices expr)))
  (lambda (env succeed fail)
    (define (try-next choices)
      (if (empty? choices)
        (fail)
        ((first choices) env
                         succeed
                         (lambda ()
                           (try-next (rest choices))))))
    (try-next cprocs)))

;; my-require
(define (my-require? expr) (tagged-list? expr 'my-require))
(define (my-require-predicate expr) (second expr))
(define (analyze-my-require expr)
  (define pproc (analyze (my-require-predicate expr)))
  (lambda (env succeed fail)
    (pproc env
           (lambda (pred-value fail2)
             (if (not pred-value)
               (fail2)
               (succeed 'ok fail2)))
           fail)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 3. SELF-EVALUATING EXPRESSIONS, VARIABLES, AND QUOTATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tagged-list? expr tag)
  (if (pair? expr)
    (eq? (first expr) tag)
    false))
(define *reserved-symbols*
  (list
    '*unassigned*
    ))

;; Only numbers, strings, and reserved symbols are self-evaluating.
(define (self-evaluating? expr)
  (or (number? expr)
      (string? expr)
      (member expr *reserved-symbols*)))
(define (analyze-self-evaluating expr)
  (lambda (env succeed fail)
    (succeed expr fail)))
(define (variable? expr)
  (and (symbol? expr)
       (not (member expr *reserved-symbols*))))
(define (analyze-variable expr)
  (lambda (env succeed fail)
    (succeed (lookup-variable-value expr env)
             fail)))

;; Quotations have the form:  (quote <text-of-quotation>)
(define (quoted? expr)
  (tagged-list? expr 'quote))
(define (text-of-quotation expr)
  (second expr))
(define (analyze-quoted expr)
  (define qval (text-of-quotation expr))
  (lambda (env succeed fail)
    (succeed qval fail)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4. DEFINITION AND ASSIGNMENT  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Variable definitions have the form:  (define <var> <value>)

;; Procedure definitions have the form:
;; (define (<var> <parameter-1> ... <parameter-n>) <body>)
;; which is equivalent to:
;; (define <var> (lambda (<parameter-1> ... <parameter-n>) <body>))
(define (definition? expr) (tagged-list? expr 'define))
(define (definition-variable expr)
  (if (symbol? (second expr))
    (second expr)
    (first (second expr))))
(define (definition-value expr)
  (if (symbol? (second expr))
    (third expr)
    (make-lambda (rest (second expr)) ; formal parameters
                 (drop expr 2))))
(define (analyze-definition expr)
  (define var (definition-variable expr))
  (define vproc (analyze (definition-value expr)))
  (lambda (env succeed fail)
    (vproc env
           (lambda (val fail2)
             (define-variable! var val env)
             (succeed 'ok fail2))
           fail)))

;; Assignments have the form:  (set! <var> <value>)
(define (assignment? expr)
  (tagged-list? expr 'set!))
(define (assignment-variable expr) (second expr))
(define (assignment-value expr) (third expr))
; must remember old value to restore if branch later fails
(define (analyze-assignment expr)
  (define var (assignment-variable expr))
  (define vproc (analyze (assignment-value expr)))
  (lambda (env succeed fail)
    (vproc env
           (lambda (val fail2)      ; *1*
             (define 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)))

;; Permanent assignments have the form:  (permanent-set! <var> <value>)
(define (permanent-assignment? expr)
  (tagged-list? expr 'permanent-set!))
(define (permanent-assignment-variable expr) (second expr))
(define (permanent-assignment-value expr) (third expr))
; do not restore old value if branch later fails
(define (analyze-permanent-assignment expr)
  (define var (permanent-assignment-variable expr))
  (define vproc (analyze (permanent-assignment-value expr)))
  (lambda (env succeed fail)
    (vproc env
           (lambda (val fail2)
             (set-variable-value! var val env)
             (succeed 'ok
                      (lambda ()
                        (fail2))))
           fail)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 5. LAMBDAS, PROCEDURES AND APPLICATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Lambda expressions have the form:
;; (lambda (<parameters>) <body>)
(define (lambda? expr) (tagged-list? expr 'lambda))
(define (lambda-parameters expr) (second expr))
(define (lambda-body expr)
  (drop expr 2))
(define (make-lambda parameters body)
  (cons 'lambda (cons parameters body)))
(define (scan-out-defines body)
  (define defines (filter definition? body))
  (cond [(empty? defines) body]
        [else
          (define rest-of-body (filter-not definition? body))
          (define vars (map definition-variable defines))
          (define vals (map definition-value defines))
          (define bindings
            (for/list ([v vars])
                      (list v '*unassigned*)))
          (define assigns
            (for/list ([v vars]
                       [e vals])
                      (list 'set! v e)))
          ; a body is a list of expressions
          (list
            (make-let
              bindings
              (append assigns rest-of-body)))]))
(define (analyze-lambda expr) ; changed
  (define vars (lambda-parameters expr))
  (define bproc (analyze-sequence (scan-out-defines (lambda-body expr))))
  (lambda (env succeed fail)
    (succeed (make-procedure vars bproc env)
             fail)))

;; Procedures:
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (procedure-parameters p) (second p))
(define (procedure-body p) (third p))
(define (procedure-environment p) (fourth p))

;; Procedure applications have the from:
;; (<var> <parameter> ...)
(define (application? expr) (pair? expr))
(define (operator expr) (first expr))
(define (operands expr) (rest expr))
(define (no-operands? ops) (empty? ops))
(define (first-operand ops) (first ops))
(define (rest-operands ops) (rest ops))
(define (analyze-application expr)
  (define fproc (analyze (operator expr)))
  (define aprocs (map analyze (operands expr)))
  (lambda (env succeed fail)
    (fproc env
           (lambda (proc fail2)
             (get-args aprocs
                       env
                       (lambda (args fail3)
                         (execute-application
                           proc args succeed fail3))
                       fail2))
           fail)))

;; "In get-args, notice how cdring down the list of aproc execution procedures and
;; consing up the resulting list of args is accomplished by calling each aproc in the
;; list with a success continuation that recursively calls get-args. Each of these
;; recursive calls to get-args has a success continuation whose value is the cons of
;; the newly obtained argument onto the list of accumulated arguments:"

(define (get-args aprocs env succeed fail)
  (if (empty? aprocs)
    (succeed empty fail)
    ((first aprocs) env
                    ; success continuation for this aproc
                    (lambda (arg fail2)
                      (get-args (rest 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)]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 6. SEQUENCES AND BEGIN EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Begin has the form:  (begin <actions>)
(define (begin? expr) (tagged-list? expr 'begin))
(define (begin-actions expr) (rest expr))
(define (last-exp? seq) (empty? (rest seq)))
(define (first-exp seq) (first seq))
(define (rest-exps seq) (rest seq))
(define (sequence->exp seq)
  (cond [(empty? seq) seq]
        [(last-exp? seq) (first-exp seq)]
        [else (make-begin seq)]))
(define (make-begin seq) (cons 'begin seq))
(define (analyze-sequence exprs)
  (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 (empty? rest-procs)
      first-proc
      (loop (sequentially first-proc (first rest-procs))
            (rest rest-procs))))
  (define procs (map analyze exprs))
  (if (empty? procs) (error "Empty sequence -- ANALYZE")
    (loop (first procs) (rest procs))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 7. BOOLEAN EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (true? x) (not (false? x)))
(define (and? expr) (tagged-list? expr 'and))
(define (and-operands expr) (rest expr))
(define (make-and sequence) (cons 'and sequence))
(define (and->if expr)
  (expand-and-operands (and-operands expr)))
(define (expand-and-operands ops)
  (cond [(empty? ops) 'true]
        [else
          (define first-op (first ops))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) first-op]
                [else
                  (make-if first-op
                           (and->if (make-and rest-ops))
                           'false)])]))
(define (or? expr) (tagged-list? expr 'or))
(define (or-operands expr) (rest expr))
(define (make-or sequence) (cons 'or sequence))
(define (or->if expr)
  (expand-or-operands (or-operands expr)))
(define (expand-or-operands ops)
  (cond [(empty? ops) 'false] ; (or) should return false
        [else
          (define first-op (first ops))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) first-op] ; (or x) should return x
                [else
                  (make-if first-op
                           first-op ; inefficient second evaluation
                           (or->if (make-or rest-ops)))])]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 8. IF AND COND EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Conditionals have the form:  (if <predicate> <consequent> <alternative>)
;; If no alternative, use false.
(define (if? expr) (tagged-list? expr 'if))
(define (if-predicate expr) (second expr))
(define (if-consequent expr) (third expr))
(define (if-alternative expr)
  (if (not (empty? (drop expr 3)))
    (fourth expr)
    'false))
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))
(define (analyze-if expr)
  (define pproc (analyze (if-predicate expr)))
  (define cproc (analyze (if-consequent expr)))
  (define aproc (analyze (if-alternative expr)))
  (lambda (env succeed fail)
    (pproc env
           ; success continuation for evaluating the predicate
           ; to obtain pred-value
           (lambda (pred-value fail2)
             (if pred-value ; (true? pred-value)
               (cproc env succeed fail2)
               (aproc env succeed fail2)))
           ; failure continuation for evaluating the predicate
           fail)))

;; if-fail has the form:  (if-fail <success-clause> <failure-clause>)
(define (if-fail? expr) (tagged-list? expr 'if-fail))
(define (if-fail-success-clause expr) (second expr))
(define (if-fail-failure-clause expr) (third expr))
(define (analyze-if-fail expr)
  (define sproc (analyze (if-fail-success-clause expr)))
  (define fproc (analyze (if-fail-failure-clause expr)))
  (lambda (env succeed fail)
    (sproc env
           (lambda (val fail2)
             (succeed val fail2))
           (lambda () (fproc env succeed fail)))))

;; Cond has the form:
;; (cond ((<predicate> <actions>)
       ;; (else <actions>))) ; if no else, assume (else false) clause
(define (cond? expr) (tagged-list? expr 'cond))
(define (cond-clauses expr) (rest expr))
;; regular cond clause
(define (cond-predicate clause) (first clause))
(define (cond-actions clause) (rest clause))
;; alternate test clause
(define (cond-alternate-clause? clause)
  (eq? (second clause) '=>))
(define (cond-test clause) (first clause))
(define (cond-recipient clause) (third clause))
;; else clause
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))
;; derive cond from if
(define (cond->if expr)
  (expand-clauses (cond-clauses expr)))
(define (expand-clauses clauses)
  (cond [(empty? clauses) 'false] ; no else clause
        [else
          (define first-clause (first clauses))
          (define rest-clauses (rest clauses))
          (cond [(cond-else-clause? first-clause)
                 (if (empty? rest-clauses)
                   (sequence->exp (cond-actions first-clause))
                   (error "ELSE clause is not last -- COND->IF" clauses))]
                [(cond-alternate-clause? first-clause)
                 (define test (cond-test first-clause)) ; gets evaluated twice
                 (make-if test
                          (list (cond-recipient first-clause)
                                test)
                          (expand-clauses rest-clauses))]
                [else
                  (make-if (cond-predicate first-clause)
                           (sequence->exp (cond-actions first-clause))
                           (expand-clauses rest-clauses))])]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 9. LET, LET*, NAMED-LET, AND LETREC  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Let has the form:  (let (<bindings>) <body>)
(define (let? expr)
  (and (tagged-list? expr 'let)
       (list? (second expr))))
(define (let-bindings expr) (second expr))
(define (let-parameters expr) (map first (let-bindings expr)))
(define (let-expressions expr) (map second (let-bindings expr)))
(define (let-body expr) (drop expr 2))
(define (let->combination expr)
  (cond [(empty? (let-bindings expr)) ; do not unnecessarily lambda wrap
         (sequence->exp (let-body expr))]
        [else
          (cons (make-lambda (let-parameters expr)
                             (let-body expr))
                (let-expressions expr))]))
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

;; Let* has the same form as let, but bindings are sequential.
(define (let*? expr) (tagged-list? expr 'let*))
(define (let*-bindings expr) (second expr))
(define (let*-body expr) (drop expr 2))
(define (make-let* bindings body)
  (cons 'let* (cons bindings body)))
(define (let*->nested-lets expr)
  (define bindings (let*-bindings expr))
  (cond [(empty? bindings)
         (sequence->exp (let-body expr))]
        [else
          (list 'let
                (list (first bindings))
                (let*->nested-lets
                  (make-let* (rest bindings)
                             (let-body expr))))]))

;; Named-let has the form:  (let <name> (<bindings>) <body>)
(define (named-let? expr)
  (and (tagged-list? expr 'let)
       (not (list? (second expr)))))
(define (named-let-name expr) (second expr))
(define (named-let-bindings expr) (third expr))
(define (named-let-parameters expr) (map first (named-let-bindings expr)))
(define (named-let-expressions expr) (map second (named-let-bindings expr)))
(define (named-let-body expr) (drop expr 3))
(define (named-let->sequence expr)
  (define bindings (named-let-bindings expr))
  (cond [(empty? bindings)
         (sequence->exp (named-let-body expr))]
        [else
          (list 'begin
                (cons 'define ; first define the named function
                      (cons (cons (named-let-name expr)
                                  (named-let-parameters expr))
                            (named-let-body expr)))
                (cons (named-let-name expr) ; then apply it to the expressions
                      (named-let-expressions expr)))]))

;; Letrec has the same form as let, but letrec parameters are first bound to
;; '*unassigned* and then set! to their values to mimic simultaneous definitions.
(define (letrec? expr) (tagged-list? expr 'letrec))
(define (letrec-bindings expr) (second expr))
(define (letrec-body expr) (drop expr 2))
(define (letrec->simultaneous-lets expr)
  (define bindings (letrec-bindings expr))
  (cond [(empty? bindings)
         (letrec-body expr)]
        [else
          (define vars (map first bindings))
          (define vals (map second bindings))
          (define new-bindings
            (for/list ([v vars])
                      (list v '*unassigned*)))
          (define assigns
            (for/list ([v vars]
                       [e vals])
                      (list 'set! v e)))
          (make-let
            new-bindings
            (append assigns (letrec-body expr)))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 10. ENVIRONMENT AND FRAMES  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; An environment is a mutable list of frames.  The enclosing environment is the mcdr
;; of the list.  A frame is a mutable list of bindings with a 'frame header.  A
;; binding is a var-val pair ie (mcons var val).

;; Environments support four procedures:
    ;; lookup-variable-value
    ;; extend-environment
    ;; define-variable
    ;; set-variable-value

;; Two helper functions support the environment procedures:
    ;; find-binding-in-frame
    ;; find-binding-in-environment

(define (enclosing-environment env) (mcdr env))
(define (first-frame env) (mcar env))
(define the-empty-environment empty)
(define the-empty-frame (mlist 'frame))
(define (empty-frame? frame)
  (empty? (frame-bindings frame)))
(define (make-frame vars vals)
  (mcons 'frame
         (mmap mcons
               (list->mlist vars)
               (list->mlist vals))))
(define (frame-bindings frame) (mcdr frame))
(define (frame-variables frame) (mmap mcar (frame-bindings frame)))
(define (frame-values frame) (mmap mcdr (frame-bindings frame)))

(define (binding-variable binding) (mcar binding))
(define (binding-value binding) (mcdr binding))
(define (set-value! binding val) (set-mcdr! binding val))
(define (add-binding-to-frame! var val frame)
  (mappend! frame (mlist (mcons var val))))
(define (find-binding-in-frame var frame)
  ; Return the var-val pair if present else false.
  (define (loop bindings)
    (cond [(empty? bindings) false]
          [else
            (define b (mcar bindings))
            (if (eq? var (binding-variable b))
              b
              (loop (mcdr bindings)))]))
  (loop (frame-bindings frame)))
(define (find-binding-in-env var env)
  ; Return the closest binding for var if present else false.
  (cond [(eq? env the-empty-environment) false]
        [else
          (define b (find-binding-in-frame var (first-frame env)))
          (or b (find-binding-in-env var (enclosing-environment env)))]))

;; (define (lookup-variable-value var env)
  ;; (define b (find-binding-in-env var env))
  ;; (cond [(not b) (error "Unbound variable" var)]
        ;; [else
          ;; (define val (binding-value b))
          ;; (if (eq? val '*unassigned*)
            ;; (error "Unassigned variable" var)
            ;; val)]))
(define (lookup-variable-value var env)
  (define b (find-binding-in-env var env))
  (if (false? b)
    (error "Unbound variable" var)
    (binding-value b)))
(define (extend-environment vars vals base-env)
  (cond [(= (length vars) (length vals))
         (mcons (make-frame vars vals) base-env)]
        [else
          (if (< (length vars) (length vals))
            (error "Too many arguments supplied" vars vals)
            (error "Too few arguments supplied" vars vals))]))
(define (define-variable! var val env)
  (define frame (first-frame env))
  (define b (find-binding-in-frame var frame))
  (if b
    (set-value! b val)
    (add-binding-to-frame! var val frame)))
(define (set-variable-value! var val env)
  (define b (find-binding-in-env var env))
  (if b
    (set-value! b val)
    (error "Unbound variable -- SET!" var)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 11. PRIMITIVE PROCEDURES AND THE GLOBAL ENVIRONMENT  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define primitive-procedures
  (list
    ; booleans
    (list 'not not)
    (list 'false? false?)
    (list 'true? (lambda (x) (not (false? x))))
    ; symbols
    (list 'eq? eq?)
    ; lists
    (list 'cons cons)
    (list 'car car)
    (list 'cdr cdr)
    (list 'list list)
    (list 'member member)
    (list 'empty? empty?)
    (list 'first first)
    (list 'rest rest)
    (list 'second second)
    ; numbers
    (list 'even? even?)
    (list 'odd? odd?)
    (list '+ +)
    (list '* *)
    (list '- -)
    (list '< <)
    (list '> >)
    (list '<= <=)
    (list '>= >=)
    (list '= =)
    (list 'abs abs)
    (list 'prime? prime?)
    ))
(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc)
  (second proc))
(define (primitive-procedure-names)
  (map first primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (second proc)))
       primitive-procedures))
(define apply-in-underlying-scheme apply)
;; The metacircular evaluator's apply is my-apply.
(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme
    (primitive-implementation proc) args))

(define (setup-environment)
  (define 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))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 12. REPL OPERATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(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)
    (define input (read))
    (cond [(eq? input 'try-again) (try-again)]
          [else
            (displayln ";;; 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 ()
      (displayln ";;; There is no current problem")
      (driver-loop))))
(define prompt-for-input displayln)
(define announce-output displayln)
(define (user-print object)
  (if (compound-procedure? object)
    (displayln (list 'compound-procedure
                   (procedure-parameters object)
                   (procedure-body object)
                   '<procedure-env>))
    (displayln object)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 13. INSTALL SOME HELPER FUNCTIONS ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define helpers
  (list
    '(define (distinct? items)
       (cond [(empty? items) true]
             [(empty? (cdr items)) true]
             [(member (car items) (cdr items)) false]
             [else (distinct? (cdr items))]))
    '(define (an-element-of items)
       (my-require (not (empty? items)))
       (amb (car items) (an-element-of (cdr items))))
    '(define (an-integer-starting-from n)
       (amb n (an-integer-starting-from (+ n 1))))
    ))
(define (install-helpers)
  (define (install expr)
    (ambeval expr
             the-global-environment
             (lambda (value fail) value)
             (lambda () 'failed)))
  (for ([e helpers])
    (install e))
  'helper-functions-installed)
(install-helpers)