Scheme Interpreter Including Ambiguous Evaluator

amb.scm

#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)