; ambmicro - a microscopic version of scheme---nondeterministic version

; This version of ambmicro has a built-in tracer to show the expressions
; that get evaluated and the backtracking that occurs.  When loaded
; into Mzscheme or executed in DrScheme, it immediately enters the
; read-amb-eval-print loop.  The exit command terminates Scheme as
; well as ambmicro.

; The following scheme-like functions and key words are defined,
; though they may not have identical behavior:

; #t,(),#f,quote,cond,set!,begin,lambda,car cdr,cons,pair?,not,exit,
; null?,eq?,*,+,primitive,procedure,define,else,amb.

; To leave ambmicro, use the (exit) command.

(define (amb-eval s environment succeed1 fail1)
(define succeed (lambda (val fail)
  (display s)
  (display " evaluates to ")
  (display val)
  (newline)
  (succeed1 val fail)))
(define fail (lambda ()
  (display "backtracking...")
  (newline)
  (fail1)))
(display "Evaluating ")
(display s)
(newline)
  (cond ((not (pair? s))
         (succeed
           (cond ((eq? s '#t) '#t)
                 ((eq? s '()) '())
                 ((eq? s '#f) '#f)
                 ((number? s) s)
		 ((string? s) s)
                 (else (micro-value s environment)))
	   fail))
        ((eq? (car s) 'quote) (succeed (cadr s) fail))
        ((eq? (car s) 'cond)
           (micro-evalcond (cdr s) environment succeed fail))
        ((eq? (car s) 'set!)
           (micro-set! (cadr s) (caddr s) environment succeed fail))
        ((eq? (car s) 'begin)
            (micro-evalbegin (cdr s) environment succeed fail))
	((eq? (car s) 'define)
	 (amb-eval (definition-val s)
	           environment
		   (lambda (val fail)
		     (micro-define-var (definition-var s) val environment)
		     (succeed 'ok fail))
	           fail))
	((eq? (car s) 'unknown) (fail))
	((eq? (car s) 'amb)
	  (micro-amb (cdr s) environment succeed fail))
        ((eq? (car s) 'lambda)
	 (succeed
           (list 'procedure (cadr s) (cons 'begin (cddr s)) environment)
	   fail))
        (else 
	  (amb-eval (car s)
	            environment
		    (lambda  (proc fail)
		      (get-args  (cdr s)
		                 environment
				 (lambda (args fail)
				   (micro-apply proc 
				                args
						environment
						succeed
						fail))
				 fail))
		    fail))))

(define (get-args arglist env succeed fail)
  (if (null? arglist)
      (succeed () fail)
      (amb-eval (car arglist)
                env
		(lambda (arg fail)
		  (get-args (cdr arglist)
		            env
			    (lambda (args fail)
			      (succeed (cons arg args) fail))
		            fail))
	        fail)))

(define (micro-apply function args environment succeed fail)
  (cond ((not (pair? function))
	 (display "ERROR: ")
	 (display function)
	 (display " is not a function")
	 (newline)
	 (fail))
	((eq? (car function) 'primitive)
	  (succeed (apply (cadr function) args) fail))
        ((eq? (car function) 'procedure)
           (amb-eval (caddr function)
                     (micro-bind (cadr function)
                                 args
                                 (cadddr function))
		     succeed
		     fail))))

(define (micro-amb choices env succeed fail)
  (if (null? choices)
      (fail)
      (amb-eval (car choices)
                env
		succeed
		(lambda ()
		  (micro-amb (cdr choices)
		             env
			     succeed
			     fail)))))

(define global-frame
  (map (lambda (x) (list x 'primitive (eval x)))
       '(car cdr cons pair? not exit null? eq? * +)))

(define global-environment (list global-frame))

(define (micro-r-e-p)
       (define (main-loop try-again)
          (newline)
          (display "ambmicro> ")
          (let ((s (read)))
	    (if (eq? s 'try-again)
	        (try-again)
	        (begin
	          (display "new problem")
		  (newline)
		  (amb-eval s
		            global-environment
			    (lambda (val next-try)
			      (micro-print val)
			      (main-loop next-try))
		            (lambda ()
			      (display "no more values for ")
			      (micro-print s)
			      (micro-r-e-p)))))))
       (main-loop (lambda ()
                     (display "no current problem")
		     (newline)
		     (micro-r-e-p))))

(define (micro-evalcond clauses environment succeed fail)
  (cond ((null? clauses) (succeed #f fail))
	((eq? (caar clauses) 'else)
	 (micro-evalbegin (cdar clauses) environment succeed fail))
        (else (amb-eval (caar clauses)
	                environment
                        (lambda (val fail)
			  (if val
			      (micro-evalbegin (cdar clauses)
			                       environment
					       succeed
					       fail)
                              (micro-evalcond (cdr clauses)
			                      environment
					      succeed
					      fail)))
		        fail))))

; An environment is a list of frames.  A frame is a list of var-value
; pairs (an assoc list).

(define (micro-bind key-list value-list environment)
  (define (micro-binder key-list value-list)  ; returns a new frame
    (cond ((or (null? key-list) (null? value-list))
            '())
          (else (cons (cons (car key-list) (car value-list))
                      (micro-binder (cdr key-list)
                                    (cdr value-list))))))
  (cons (micro-binder key-list value-list) environment))

(define (micro-get-var-val var environment)
  (if (null? environment)
      #f
      (let ((vv (assoc var (car environment))))
	   (if vv
	       vv
	       (micro-get-var-val var (cdr environment))))))

(define (micro-value var environment)
  (let ((vv (micro-get-var-val var environment)))
       (if vv
           (cdr vv)
           (begin
	     (display "ERROR: No value for ")
	     (display var)
	     (display " found")
	     (newline)
	     'unknown))))

(define (micro-set! var val env succeed fail)
  (let ((entry (micro-get-var-val var env)))
       (if entry
	   (let ((old-val (cdr entry)))
	     (amb-eval val
	               env
		       (lambda (val fail)
		         (set-cdr! entry val)
	                 (succeed 'ok
			          (lambda ()
				    (set-cdr! entry old-val)
				    (fail))))
		       fail))
           (begin
	     (display "ERROR: variable ")
	     (display var)
	     (display " not previously defined")
	     (newline)
	     (fail)))))

(define (micro-evalbegin exprs env succeed fail)
  (if (null? (cdr exprs))
      (amb-eval (car exprs) env succeed fail)
      (amb-eval (car exprs)
                env
		(lambda (val fail)
                   (micro-evalbegin (cdr exprs)
		                    env
				    succeed
				    fail))
	        fail)))

(define (definition-var s)
  (if (symbol? (cadr s))
      (cadr s)
      (caadr s)))

(define (definition-val s)
  (if (symbol? (cadr s))
      (caddr s)
      (cons 'lambda (cons (cdadr s) (cddr s)))))

(define (micro-define-var var val env)
  (let ((vv (assoc var (car env))))  ; search only first frame
       (if vv
	   (set-cdr! vv val)
	   (set-car! env (cons (cons var val) (car env))))))

; here is a print command you can use to debug micro.  Use it in place
; of display in any debugging statements you want to insert.

(define (micro-print x)
  (cond ((not (pair? x)) (display x))

    ; we don't want to print out environments in procedures because they may
    ; be circular lists.

        ((eq? (car x) 'procedure)
         (display "(procedure ")
         (micro-print-help (list (cadr x) (caddr x)))
         (display " <an environment>)"))

    ; otherwise, print out the list.

        (else (display "(")
              (micro-print-help x)
              (display ")"))))

; micro-print-help prints the elements of a list with a space between them

(define (micro-print-help x)
  (if (pair? x)
      (begin (micro-print (car x))
             (if (pair? (cdr x))
	         (display " ")
		 (if (not (null? (cdr x))) (display " . ")))
             (micro-print-help (cdr x)))
      (if (not (null? x)) (display x))))

(micro-r-e-p)