Pasted

#lang racket
(require rackunit
         "4-3-3-exercises-amb-repl-program.rkt")
 
;; The same as 4-3-3-amb-repl-test.rkt except that there are two new test cases, one
;; for permanent-set! and one for if-fail.
 
;; default succeed and fail continuations used in calls to ambeval
(define dsc (lambda (val fail) val))
(define dfc (lambda () 'failed))
 
(test-case "self-evaluating expression"
           (check-equal? (ambeval "x" the-global-environment dsc dfc)
                         "x")
           (check-equal? (ambeval 23 the-global-environment dsc dfc)
                         23)
           )
 
(test-case "quotation"
           (define quote-expr '(quote ("x" 23 a)))
           (check-equal? (ambeval quote-expr the-global-environment dsc dfc)
                         '("x" 23 a))
           )
 
(test-case "variable definition"
           (define def-expr '(define a 42))
           (check-equal? (ambeval def-expr the-global-environment dsc dfc)
                         'ok)
           (check-equal? (ambeval 'a the-global-environment dsc dfc)
                         42)
           )
 
(test-case "procedure definition"
           (define proc-expr '(define (multiply x y) (* x y)))
           (check-equal? (ambeval proc-expr the-global-environment dsc dfc)
                         'ok)
           )
 
(test-case "procedure application"
           (define application-expr '(multiply 3 4))
           (check-equal? (ambeval application-expr the-global-environment dsc dfc)
                         12)
           (check-equal? (ambeval '(car (cons 1 (cons 2 '())))
                                  the-global-environment
                                  dsc
                                  dfc)
                         1)
           )
 
(test-case "assignment"
           (define assign-expr '(set! a 23))
           (check-equal? (ambeval assign-expr the-global-environment dsc dfc)
                         'ok)
           (check-equal? (ambeval 'a the-global-environment dsc dfc)
                         23)
           )
 
(test-case "predicate"
           (check-true (true? (ambeval 'a the-global-environment dsc dfc)))
           (check-true (true? (ambeval "false" the-global-environment dsc dfc)))
           (check-false (true? (ambeval 'false the-global-environment dsc dfc)))
           (check-true (false? (ambeval 'false the-global-environment dsc dfc)))
           )
 
(test-case "if statement"
           (define ie '(if true 1 2))
           (check-equal? (ambeval ie the-global-environment dsc dfc)
                         1)
           (define ie2 '(if false 1 2))
           (check-equal? (ambeval ie2 the-global-environment dsc dfc)
                         2)
           )
 
(test-case "cond statement"
           (define ce '(cond ("a" 1 2) ("b" 3)))
           (check-equal? (ambeval ce the-global-environment dsc dfc)
                         2)
           (define alt-ce '(cond ((cons 1 (cons 2 '())) => car) (else 87)))
           (check-equal? (ambeval alt-ce the-global-environment dsc dfc)
                         1)
           )
 
(test-case "begin statement"
           (define be '(begin "a" "b" 1 2 (* 3 4)))
           (check-equal? (ambeval be the-global-environment dsc dfc)
                         12)
           )
 
(test-case "boolean operator"
           (ambeval '(define c 38) the-global-environment dsc dfc)
           (check-equal? (ambeval '(and 1 "a" c) the-global-environment dsc dfc)
                         38)
           (check-equal? (ambeval '(and 1 1 false) the-global-environment dsc dfc)
                         false)
           (check-equal? (ambeval '(or false false 1)
                                  the-global-environment
                                  dsc
                                  dfc)
                         1)
           (check-equal? (ambeval '(or false false false)
                                  the-global-environment
                                  dsc
                                  dfc)
                         false)
           )
 
(test-case "let"
           (define le '(let ((x 1) (y 2) (z 3)) 'side-effect (+ x y z)))
           (check-equal? (ambeval le the-global-environment dsc dfc)
                         6)
           (define le2 '(let ((x 1) (y 2)) (+ x y)))
           (check-equal? (ambeval le2 the-global-environment dsc dfc)
                         3)
           (define le3 '(let ((x 1)) 'side-effect (+ x 2)))
           (check-equal? (ambeval le3 the-global-environment dsc dfc)
                         3)
           (define le4 '(let () 'side-effect (+ 3 2)))
           (check-equal? (ambeval le4 the-global-environment dsc dfc)
                         5)
           (define le5 '(let () (+ 3 2)))
           (check-equal? (ambeval le5 the-global-environment dsc dfc)
                         5)
           ; let with internal defines
           (define le6 '(let ([x 1])
                          (define y 2)
                          (+ x y)))
           (check-equal? (ambeval le6 the-global-environment dsc dfc)
                         3)
           (define le7 '(let* ([x 1]
                               [y (+ x 1)])
                          (define z (+ x y))
                          (define w (+ z 1))
                          (+ x y z w)))
           (check-equal? (ambeval le7 the-global-environment dsc dfc)
                         10)
           )
 
(test-case "named-let"
           (ambeval '(define (fib n)
                       (let fib-iter ((a 1)
                                      (b 0)
                                      (my-count n))
                         (if (= my-count 0)
                           b
                           (fib-iter (+ a b) a (+ my-count -1)))))
                    the-global-environment
                    dsc
                    dfc)
           (check-equal? (ambeval '(fib 0) the-global-environment dsc dfc)
                         0)
           (check-equal? (ambeval '(fib 1) the-global-environment dsc dfc)
                         1)
           (check-equal? (ambeval '(fib 10) the-global-environment dsc dfc)
                         55)
           )
 
(test-case "let*"
           (define lse '(let* ((x 1) (y (+ x 1)) (z (+ y 1))) (+ x y z)))
           (check-equal? (ambeval lse the-global-environment dsc dfc)
                         6)
           (define lse2 '(let* ((a 1) (b 2)) 'side-effect (+ a b)))
           (check-equal? (ambeval lse2 the-global-environment dsc dfc)
                         3)
           (define lse3 '(let* ((a 1)) 'side-effect (+ a 2)))
           (check-equal? (ambeval lse3 the-global-environment dsc dfc)
                         3)
           (define lse4 '(let* ((a 1)) (+ a 2)))
           (check-equal? (ambeval lse4 the-global-environment dsc dfc)
                         3)
           )
 
(test-case "letrec"
           (ambeval '(define (my-even? x)
                       (letrec ((ev? (lambda (n)
                                       (if (= n 0)
                                         true
                                         (od? (- n 1)))))
                                (od? (lambda (n)
                                       (if (= n 0)
                                         false
                                         (ev? (- n 1))))))
                         (ev? x)))
                    the-global-environment
                    dsc
                    dfc)
           (check-equal? (ambeval '(my-even? 11) the-global-environment dsc dfc)
                         false)
           (check-equal? (ambeval '(my-even? 12) the-global-environment dsc dfc)
                         true)
           )
 
(test-case "multiple-dwelling"
           (ambeval '(define (multiple-dwelling)
                       (let ([baker (an-element-of (list 1 2 3 4 5))])
                         (my-require (not (= baker 5)))
                         (let ([cooper (amb 1 2 3 4 5)])
                           (my-require (not (= cooper 1)))
                           (let ([fletcher (amb 1 2 3 4 5)])
                             (my-require (not (= fletcher 5)))
                             (my-require (not (= fletcher 1)))
                             (my-require (not (= (abs (- fletcher cooper)) 1)))
                             (let ([miller (amb 1 2 3 4 5)])
                               (my-require (> miller cooper))
                               (let ([smith (amb 1 2 3 4 5)])
                                 (my-require (distinct? (list baker
                                                              cooper
                                                              fletcher
                                                              miller
                                                              smith)))
                                 (my-require (not (= (abs (- smith fletcher)) 1)))
                                 (list (list 'baker baker)
                                       (list 'cooper cooper)
                                       (list 'fletcher fletcher)
                                       (list 'miller miller)
                                       (list 'smith smith))))))))
                    the-global-environment
                    dsc
                    dfc)
           (check-equal? (ambeval '(multiple-dwelling)
                                  the-global-environment
                                  dsc
                                  dfc)
                         '((baker 3)
                           (cooper 2)
                           (fletcher 4)
                           (miller 5)
                           (smith 1))) 
           )
 
(test-case "fathers-daughters-and-yachts"
           (ambeval '(define (fathers-daughters-and-yachts)
                       (define names '(mary-ann gabrielle lorna rosalind melissa))
                       (let ([parker-daughter (an-element-of names)]
                             [parker-yacht (an-element-of names)]
                             [hood-daughter 'melissa]
                             [hood-yacht 'gabrielle]
                             [moore-daughter (an-element-of names)]
                             [moore-yacht 'lorna]
                             [downing-daughter (an-element-of names)]
                             [downing-yacht 'melissa]
                             [hall-daughter (an-element-of names)]
                             [hall-yacht 'rosalind])
                         (my-require (distinct?
                                       (list moore-daughter
                                             downing-daughter
                                             hall-daughter
                                             hood-daughter
                                             parker-daughter)))
                         (my-require (distinct?
                                       (list moore-yacht
                                             downing-yacht
                                             hall-yacht
                                             hood-yacht
                                             parker-yacht)))
                         (my-require (eq? moore-daughter 'mary-ann))
                         (my-require (not (eq? moore-daughter moore-yacht)))
                         (my-require (not (eq? downing-daughter downing-yacht)))
                         (my-require (not (eq? hall-daughter hall-yacht)))
                         (my-require (not (eq? hood-daughter hood-yacht)))
                         (my-require (not (eq? parker-daughter parker-yacht)))
                         (my-require (or (not (eq? moore-daughter 'gabrielle))
                                         (eq? moore-yacht parker-daughter)))
                         (my-require (or (not (eq? downing-daughter 'gabrielle))
                                         (eq? downing-yacht parker-daughter)))
                         (my-require (or (not (eq? hall-daughter 'gabrielle))
                                         (eq? hall-yacht parker-daughter)))
                         (my-require (or (not (eq? hood-daughter 'gabrielle))
                                         (eq? hood-yacht parker-daughter)))
                         (my-require (or (not (eq? parker-daughter 'gabrielle))
                                         (eq? parker-yacht parker-daughter)))
                         (list (list 'moore moore-daughter)
                               (list 'downing downing-daughter)
                               (list 'hall hall-daughter)
                               (list 'hood hood-daughter)
                               (list 'parker parker-daughter))))
                    the-global-environment
                    dsc
                    dfc)
           (check-equal? (ambeval '(fathers-daughters-and-yachts)
                                  the-global-environment
                                  dsc
                                  dfc)
                         '((moore mary-ann)
                           (downing lorna)
                           (hall gabrielle)
                           (hood melissa)
                           (parker rosalind)))
           )
 
(test-case "permanent-set!"
           (ambeval '(define count 0) the-global-environment dsc dfc)
           (check-equal? (ambeval '(let ([x (an-element-of '(a b c))]
                                         [y (an-element-of '(a b c))])
                                     (permanent-set! count (+ count 1))
                                     (my-require (not (eq? x y)))
                                     (list x y count))
                                  the-global-environment
                                  dsc
                                  dfc)
                         '(a b 2))
           )
 
(test-case "if-fail"
           (check-equal? (ambeval '(if-fail (let ([x (an-element-of '(1 3 5))])
                                              (my-require (even? x))
                                              x)
                                            'all-odd)
                                  the-global-environment
                                  dsc
                                  dfc)
                         'all-odd)
           (check-equal? (ambeval '(if-fail (let ([x (an-element-of '(1 3 5 8))])
                                              (my-require (even? x))
                                              x)
                                            'all-odd)
                                  the-global-environment
                                  dsc
                                  dfc)
                         8)
           )