Skip to content

Instantly share code, notes, and snippets.

@chelseatroy
Last active Nov 16, 2019
Embed
What would you like to do?
Scheme Interpreter Including Ambiguous Evaluator
#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)
; fail is a procedure of no arguments (fail). Purpose: backtrack/unwind
;
; Rule: You can never return a result. You can only use succeed or fail.
(define (seval sexp succeed fail env)
(cond ((primitive? sexp) (succeed sexp fail))
((symbol? sexp) (succeed (lookup-environment env sexp) fail))
; Special forms
((define? sexp) (seval-define sexp succeed fail env))
((if? sexp) (seval-if sexp succeed fail env))
((begin? sexp) (seval-begin sexp succeed fail env))
((lambda? sexp) (seval-lambda sexp succeed fail env))
((amb? sexp) (seval-amb sexp succeed fail env))
((quote? sexp) (succeed sexp fail))
; Procedure application
((list? sexp) (sapply sexp succeed fail env))
(else (error "Bad expression"))))
; Evaluate many scheme expressions, returning only the value of the last one
(define (seval-many sexp-list succeed fail env)
(if (null? (cdr sexp-list))
(seval (car sexp-list) succeed fail env) ; Last expression
(begin
(seval (car sexp-list)
(lambda (result fail2)
(seval-many (cdr sexp-list) succeed fail2 env)
)
fail env))
)
)
; Basic objects like ints, floats, numbers, true/false
(define (primitive? sexp)
(or (number? sexp) (boolean? sexp)))
; Define special form
; (define name value)
; (define (proc-name parameters) exp-list)
(define (define? sexp)
(and (pair? sexp) (eq? (car sexp) 'define)))
(define (define-name sexp)
(if (pair? (cadr sexp))
(caadr sexp)
(cadr sexp)))
(define (define-value sexp)
(if (pair? (cadr sexp))
(let ((parameters (cdr (cadr sexp)))
(expressions (cddr sexp)))
(append (list 'lambda parameters) expressions)
)
(caddr sexp)
)
)
(define (seval-define sexp succeed fail env)
(let ((name (define-name sexp))
(value (define-value sexp)))
(seval value
(lambda (result fail2) (succeed (define-in-environment env name result) fail2))
fail
env)
))
; (define-in-environment env name (seval value env))))
; (if test then-clause else-clause)
(define (if? sexp)
(and (pair? sexp) (eq? (car sexp) 'if)))
(define (seval-if sexp succeed fail env)
(let ((test (if-test sexp))
(then-clause (if-then-clause sexp))
(else-clause (if-else-clause sexp)))
(seval test (lambda (test-result fail2)
(if test-result
(seval then-clause succeed fail2 env)
(seval else-clause succeed fail2 env)
)
)
fail env)))
; "selectors" (extracting info from an expression)
(define (if-test sexp) (cadr sexp))
(define (if-then-clause sexp) (caddr sexp))
(define (if-else-clause sexp) (cadddr sexp))
; (begin exp1 exp2 exp3 ... expn)
(define (begin? sexp)
(and (pair? sexp) (eq? (car sexp) 'begin)))
(define (seval-begin sexp succeed fail env)
(seval-many (cdr sexp) succeed fail env))
; (lambda (parameters) exp1 exp2 ... expn)
(define (lambda? sexp)
(and (pair? sexp) (eq? (car sexp) 'lambda)))
(define (lambda-parameters sexp) (cadr sexp))
(define (lambda-expressions sexp) (cddr sexp))
(define (seval-lambda sexp succeed fail env)
(succeed (make-procedure (lambda-parameters sexp)
(lambda-expressions sexp)
env) fail)
)
(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
(lambda () (try-next (cdr choices))) env)
)
)
(try-next (amb-choices sexp))
)
(define (make-procedure parameters expressions env)
; Creating some kind of type-tagged list or some other data structure that
; can be examined to see if it's a user procedure or not
(list 'user-procedure parameters expressions env)
)
(define (procedure-env proc)
(cadddr proc))
(define (procedure-parameters proc)
(cadr proc))
(define (procedure-expressions proc)
(caddr proc))
(define (user-procedure? proc)
(and (pair? proc) (eq? (car proc) 'user-procedure)))
; Evaluation of a procedure call
; (proc arg1 arg2 arg3 ... argn)
(define (sapply sexp succeed fail env)
(let ((args (cdr sexp)))
(seval (car sexp)
(lambda (proc fail2)
(if (user-procedure? proc)
(apply-user-procedure proc args succeed fail2 env) ; Lambda procedure
(apply-builtin-procedure proc args succeed fail2 env)) ; Builtin- Scheme/Racket procedure
)
fail env)
)
)
; Quotes
(define (quote? sexp)
(and (pair? sexp) (eq? (car sexp) 'quote)))
(define (apply-builtin-procedure proc args succeed fail env)
(evaluate-args args
(lambda (evaluated-args fail2)
(succeed (apply proc evaluated-args) fail2)) fail env)
)
; This needs to make a list of evaluated arguments (same as map)
(define (evaluate-args args succeed fail env)
(define (iter remaining-args fail2 result)
(if (null? remaining-args)
(succeed result fail2)
(seval (car remaining-args)
; success of evaluating arg
(lambda (earg fail3)
(iter (cdr remaining-args) fail3 (append result (list earg))))
fail2 env)
)
)
(iter args fail '())
)
; (let ((evaluated-args (map (lambda (arg) (seval arg env)) args)))
; (apply proc evaluated-args))
; )
(define (bind-arguments parameters args env)
(if (null? parameters)
'done
(begin
(define-in-environment env (car parameters) (car args))
(bind-arguments (cdr parameters) (cdr args) env))))
(define (apply-user-procedure proc args succeed fail env)
(evaluate-args args
(lambda (evaluated-args fail2)
(let ((new-env (make-environment (procedure-env proc))))
; bind argument values to parameter names
(bind-arguments (procedure-parameters proc) evaluated-args new-env)
; evaluate the expressions (in the lambda) in the new environment
(seval-many (procedure-expressions proc) succeed fail2 new-env)
)
)
fail env
)
)
; Implementation of the environment
; Modify: To allow nested environments
; Proposal: Define the environment as a list
(define (make-environment parent-env)
(cons (make-hash) parent-env)
)
(define (lookup-environment env name)
(if (null? env)
(error "Bad name")
(if (hash-has-key? (car env) name)
(hash-ref (car env) name)
(lookup-environment (cdr env) name))))
(define (set-environment! env name value)
(if (null? env)
(error "Bad Name")
(if (hash-has-key? (car env) name)
(hash-set! (car env) name value)
(set-environment! (cdr env) name value))))
(define (define-in-environment env name value)
(hash-set! (car env) name value)
)
; Define the "global" environment. Note: The parent environment is '() (null)
(define env (make-environment '()))
; Define the "built-in" operators
(define-in-environment env '+ +)
(define-in-environment env '- -)
(define-in-environment env '* *)
(define-in-environment env '/ /)
(define-in-environment env '< <)
(define-in-environment env '<= <=)
(define-in-environment env '> >)
(define-in-environment env '>= >=)
(define-in-environment env '= =)
(define-in-environment env 'cons cons)
(define-in-environment env 'car car)
(define-in-environment env 'cdr cdr)
(define-in-environment env 'abs abs)
(define-in-environment env 'true true)
(define-in-environment env 'list list)
(define-in-environment env 'false false)
(define-in-environment env 'displayln displayln)
(define (distinct? items)
(cond ((null? items) true)
((null? (cdr items)) true)
((member (car items) (cdr items)) false)
(else (distinct? (cdr items)))))
(define-in-environment env 'abs abs)
(define-in-environment env 'not not)
(define-in-environment env 'list list)
(define-in-environment env 'distinct? distinct?)
(try '(define (require predicate) (if predicate #t (amb))) env)
(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)))
(require (not (= cooper 1)))
(require (not (= fletcher 5)))
(require (not (= fletcher 1)))
(require (> miller cooper))
(require (not (= (abs (- smith fletcher)) 1)))
(require (not (= (abs (- fletcher cooper)) 1)))
(list (list 'baker baker)
(list 'cooper cooper)
(list 'fletcher fletcher)
(list 'miller miller)
(list 'smith smith)))) env)
(try '(multiple-dwelling) env)
(try '(define (an-element-of items)
(amb (car items) (an-element-of (cdr items)))) env)
(try '(an-element-of (list 1 2 3 4 5)) env)
(try '(define (a-number-between low-number high-number)
(if (= low-number high-number)
low-number
(amb low-number (a-number-between (+ low-number 1) high-number))
)
) env)
(try '(a-number-between 1 9) env)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment