;;; Test suite for non-deterministic evaluator

;; Most if not all test are derived from Eli's work at:
;; <https://github.com/eliben/code-for-blog/tree/master/2007/sicp>

(use-modules (srfi srfi-64))
(use-modules (sicp ch-4 ambeval))

(define (interpret exp)
  (ambeval-eval
   exp
   the-global-environment
   (lambda (val next-alternative) val)
   (lambda () 'dead-end)))

(test-begin "test-self-eval")
(test-equal 19 (interpret 19))
(test-equal "Hello Scheme!" (interpret "Hello Scheme!"))
(test-equal 666666666222 (interpret 666666666222))
(test-end "test-self-eval")


(test-begin "test-expr")
(test-equal 19 (interpret '(+ 10 9)))
(test-equal 2 (interpret '(* (- 2 3) (- 4 6))))
(test-equal 11 (interpret '(+ (* 1 2) (/ 6 2) (* (- 5 4) 2 3))))
(test-end "test-expr")


(test-begin "test-quoted")
(test-eq 'abracadabra (interpret '(quote abracadabra)))
(test-eq 'hello (interpret '(quote hello)) 'hello)
(test-equal '(jay wizz 2 watt) (interpret '(quote (jay wizz 2 watt))))
(test-end "test-quoted")


(test-begin "test-conditionals")
(test-assert (interpret '(if (= 4 5) #f 1)))
(test-assert (interpret '(if (= 5 5) 1 #f)))
(test-assert (interpret '(if #f #f #t)))
(test-assert (interpret '(if 1 #t #f)))

;; note: -cond- also tests how -begin- works
(test-assert (interpret '(cond (#f #f) (else #t))))
(test-assert (interpret '(cond (#t #t) (else #f))))
(test-assert
    (interpret
     '(cond
       ((= 5 6) #f)
       ((= 4 5) #f)
       ((= 5 5) #t)
       (else #f))))
(test-assert
    (interpret
     '(cond
       ((= 5 6) #f)
       ((= 4 5) #f)
       ((= 51 5) #f)
       (else (= 1 1)))))
(test-end "test-conditionals")


(test-begin "test-or-and")
(test-assert (not (interpret '(or))))
(test-assert (interpret '(or 1 2 3)))
(test-equal 3 (interpret '(or #f #f 3)))
(test-assert (not (interpret '(or #f #f))))

(test-assert (interpret '(and)))
(test-equal 3 (interpret '(and 1 2 3)))
(test-equal 3 (interpret '(and #t #t 3)))
(test-assert (not (interpret '(and #f #f))))
(test-end "test-or-and")


(test-begin "test-vars")
(interpret '(define num1 12))
(interpret '(define num2 5))

(test-equal 12 (interpret 'num1))
(test-assert (interpret '(= num1 12)))
(test-equal 14 (interpret '(+ num1 2)))
(test-equal 17 (interpret '(+ num1 num2)))
(test-assert (not (interpret '(= num1 num2))))

(interpret '(set! num2 10))
(interpret '(set! num1 (+ 10 num2)))
(test-equal 30 (interpret '(+ num1 num2)))
(test-end "test-vars")


(test-begin "test-procedure")
(interpret '(define (sum a b) (+ a b)))
(interpret '(define (average x y) (/ (sum x y) 2)))
(interpret '(define xx 10))
(interpret '(define yy 20))

(test-equal 6 (interpret '(sum 2 4)))
(test-equal 15 (interpret '(average xx yy)))

;; applying a lambda directly
(test-equal 20 (interpret '((lambda (x y) (+ x y)) 15 5)))

;; define an explicit lambda
(interpret '(define lsum (lambda (x y) (+ x y))))
(test-equal 23 (interpret '(lsum 11 12)))

(interpret '(set! lsum (lambda (x y) (- x y))))
(test-equal -1 (interpret '(lsum 11 12)))

;; recursive procedure
(interpret
 '(define (rsum x y)
    (if (= y 0)
	x
	(rsum (+ x 1) (- y 1)))))

(test-equal 11 (interpret '(rsum 5 6)))
(test-equal 6 (interpret '(rsum 0 6)))
(test-equal 6 (interpret '(rsum 6 0)))

;; returning a procedure from another procedure
(interpret '(define (make-adder-proc x) (lambda (y) (+ x y))))
(interpret '(define add2 (make-adder-proc 2)))

(test-equal 12 (interpret '(add2 xx)))
(test-equal 14 (interpret '((make-adder-proc 4) 10)))

;; accepting a procedure as an argument
(interpret '(define (apply-twice proc val) (proc (proc val))))

(test-equal 104 (interpret '(apply-twice add2 100)))
(test-equal 10000 (interpret '(apply-twice (lambda (x) (* x x)) 10)))

;; Compose takes two procedures, and returns a procedure that is their
;; composition.
(interpret '(define (compose f g) (lambda (x) (f (g x)))))
(interpret '(define (square x) (* x x)))
(interpret '(define (inc x) (+ x 1)))

(test-equal 121 (interpret '((compose square inc) 10)))
(test-equal 101 (interpret '((compose inc square) 10)))
(test-end "test-procedure")


(test-begin "test-let")
(test-equal 6 (interpret '(let ((a 1) (b 2) (c 3)) (+ a b c))))
(interpret '(define (abc a b) (let ((d (+ a b))) (+ d d))))
(test-equal 20 (interpret '(abc 6 4)))
(test-end "test-let")


(test-begin "test-let*")
(test-equal 39
  (interpret
   '(let* ((x 3) (y (+ x 2)) (z (+ x y 5))) (* x z))))
(test-end "test-let*")


(test-begin "test-named-let")
(interpret
 '(define (fib n)
    (let fib-iter ((a 1) (b 0) (count n))
      (if (= count 0)
	  b
	  (fib-iter (+ a b) a (- count 1))))))
(test-equal 13 (interpret '(fib 7)))
(test-equal 21 (interpret '(fib 8)))
(test-end "test-named-let")


(test-begin "test-letrec")
(interpret
 '(define (findout32 x)
    (letrec ((even?
	      (lambda (n)
		(if (= n 0)
		    #t
		    (odd? (- n 1)))))
	     (odd?
	      (lambda (n)
		(if (= n 0)
		    #f
		    (even? (- n 1))))))
      (cond
       ((even? x) 20)
       ((odd? x) 30)
       (else 40)))))

(test-equal 20 (interpret '(findout32 4)))
(test-equal 30 (interpret '(findout32 5)))
(test-end "test-letrec")


(test-begin "test-while")
(interpret '(define xx 5))
(interpret '(define yy 6))
(interpret
 '(while (> xx 0)
    (begin
      (set! xx (- xx 1))
      (set! yy (+ yy 1)))))

(test-equal 0 (interpret 'xx))
(test-equal 11 (interpret 'yy))
(test-end "test-while")


(test-begin "test-unbind")
(interpret '(define abc 12))
(test-equal 12 (interpret 'abc))
(interpret '(unbind! abc))
(test-error #t (interpret 'abc))
(test-end "test-unbind")


(test-begin "test-internal-defs")
(interpret
 '(define (kkk a b c)
    (define u (+ a b))
    (define v (+ b c))
    (* u v c)))

(test-equal 45 (interpret '(kkk 1 2 3)))

;; mutually recursive internal definitions
(interpret
 '(define (findout12 x)
    (define (even? n)
      (if (= n 0)
          #t
          (odd? (- n 1))))
    (define (odd? n)
      (if (= n 0)
          #f
          (even? (- n 1))))
    (cond
     ((even? x) 20)
     ((odd? x) 30)
     (else 40))))

(test-equal 20 (interpret '(findout12 4)))
(test-equal 30 (interpret '(findout12 5)))

;; usage before definition
(interpret
 '(define (kkk12 x)
    (define p (+ x x))
    (set! p (- x (garfield12 p)))
    (define (garfield12 x) (* x 2))
    p))

(test-equal -30 (interpret '(kkk12 10)))
(test-end "test-internal-defs")