chelseatroy

(define (amb? sexp)
  (and (pair? sexp) (eq? (car sexp) 'amb)))

(define (amb-choices sexp) (cdr sexp))
  
(define (seval-amb sexp succeed fail env)
  (define (try-next choices)
    (if (null? choices)
        (fail)
        (seval (car choices) succeed

chelseatroy

(try '(define multiple-dwelling
        (lambda ()
         (define baker (amb 1 2 3 4 5))
         (define cooper (amb 1 2 3 4 5))
         (define fletcher (amb 1 2 3 4 5))
         (define miller (amb 1 2 3 4 5))
         (define smith (amb 1 2 3 4 5))
         (require
           (distinct? (list baker cooper fletcher miller smith)))
         (require (not (= baker 5)))

chelseatroy

#lang racket

; Metacircular evaluator (AMB Evaluator)

; Helper function to evaluate an expression (with printing on success/fail)
(define (try sexp env)
  (seval sexp (lambda (result fail) (displayln result)) (lambda () (error "Nope")) env))

; Evaluate a "scheme" expression
; succeed is a procedure of two arguments (succeed result fail)

chelseatroy

(define (force-it obj)
  (if (thunk? obj)
      (define-in-environment (name thunk-exp) list('evaluated-thunk ((actual-value (thunk-exp obj) (thunk-env obj))))
      obj))
...

(define (evaluated-thunk? obj)
  (eq? (car obj) 'evaluated-thunk))
  
(define (thunk-value evaluated-thunk) (cadr evaluated-thunk))

chelseatroy

; "Thunk:" An unevaluated expression along with an environment (where it would evaluate)
(define (delay-it sexp env)
  (list 'thunk sexp env))

(define (thunk? obj)
  (and (pair? obj) (eq? (car obj) 'thunk)))

(define (thunk-exp obj)
  (cadr obj))

chelseatroy

(define (apply-builtin-procedure proc args env)
  (let ((evaluated-args (map (lambda (arg) (actual-value arg env)) args)))
        (apply proc evaluated-args))
  )

chelseatroy

(define (seval-define sexp env)
  (let ((name (define-name sexp))
        (value (define-value sexp)))
    (seval value
           (lambda (result fail2)
             (define-in-environment env name (actual-value value env name result)) fail env)      
    )))

chelseatroy

(define (force-it obj)
  (if (thunk? obj)
      (actual-value (thunk-exp obj) (thunk-env obj))
      obj))

(define (actual-value sexp env)
  (force-it (seval sexp env)))

chelseatroy

(define (seval-if sexp env)
  (let ((test (if-test sexp))
        (then-clause (if-then-clause sexp))
        (else-clause (if-else-clause sexp)))
    (if (actual-value test env)
        (seval then-clause env) 
        (seval else-clause env))))

chelseatroy

(define (seval sexp succeed fail env)
  (cond ((primitive? sexp) sexp)
        ((symbol? sexp) (succeed (lookup-environment env sexp) fail))
        ; Special forms
        ((define? sexp) (seval-define sexp env))
        ((if? sexp) (succeed (seval-if sexp env) fail)
        ((lambda? sexp) (succeed (seval-lambda sexp env) fail))
       
        ; Procedure application
        ((list? sexp) (sapply sexp env))