A16-test-code.ss

;; Test code for CSSE 304 Assignment 16

(define (test-basics)
    (let ([correct '(
		     (1 1 2 6 24 120)
		     40320
		     120
		     (#t #f #f #t)
		     )]
          [answers 
            (list 
	     (eval-one-exp '
	      (letrec ([fact (lambda (x)
			       (if (zero? x) 
				   1
				   (* x (fact (- x 1)))))])
		(map fact '(0 1 2 3 4 5))))
	     (eval-one-exp '
	      (let f ([n 8] [acc 1])
		(if (= n 0)
		    acc
		    (f (sub1 n) (* acc n)))))
	     
	     (eval-one-exp '
	      (let ([n 5])
		(let f ([n n] [acc 1])
		  (if (= n 0)
		      acc
		      (f (sub1 n) (* acc n))))))
	     
	     (eval-one-exp '
	      (letrec ([even? (lambda (n)
				(if (zero? n) 
				    #t
				    (odd? (- n 1))))]
		       [odd? (lambda (m)
			       (if (zero? m)
				   #f
				   (even? (- m 1))))])
		(list (odd? 3) (even? 3) (odd? 4) (even? 4))))	     )])
      (display-results correct answers equal?)))

(define (test-answers-are-sets)
    (let ([correct '(
		     (k e b d a c)
		     ((3 a) (2 b)(3 b) (2 a) (1 a) (1 b))
		     )]
          [answers 
            (list 
	     (eval-one-exp '
	      (letrec ([union
			(lambda (s1 s2)
			  (cond [(null? s1) s2]
				[(member? (car s1) s2) (union (cdr s1) s2)]
				[else (cons (car s1) (union (cdr s1) s2))]))]
		       [member? (lambda (sym ls)
				  (cond [(null? ls) #f]
					[(eqv? (car ls) sym) #t]
					[else (member? sym (cdr ls))]))])
		(union '(a c e d k) '(e b a d c))))
	     (eval-one-exp '
	     (letrec ([product
		       (lambda (x y)
			 (if (null? y)
			     '()
			     (let loop ([x x] [accum '()])
			       (if (null? x)
				   accum
				   (loop (cdr x)
					 (append (map (lambda (s)
							(list (car x) s))
						      y)
						 accum))))))])
	       (product '(1 2 3) '(a b))))
	     )])
      (display-results correct answers sequal?-grading)))

(define (test-additional)
    (let ([correct '(
		     (8 6 5 4 3 2 1)
		     )]
      [answers 
       (list 
	(eval-one-exp ' 
	 (letrec ([sort (lambda (pred? l) 
			  (if (null? l) l 
			      (dosort pred? l (length l))))] 
		  [merge (lambda (pred? l1 l2) 
			   (cond [(null? l1) l2] 
				 [(null? l2) l1] 
				 [(pred? (car l2) (car l1)) 
				  (cons (car l2) 
					(merge pred? l1 (cdr l2)))] 
				 [else (cons (car l1) (merge pred? 
							     (cdr l1) l2))]))] 
		  [dosort (lambda (pred? ls n) 
			    (if (= n 1) 
				(list (car ls)) 
				(let ([mid (quotient n 2)]) 
				  (merge pred? (dosort pred? ls mid) 
					 (dosort pred? 
						 (list-tail ls mid) 
						 (- n mid))))))]) 
	   (sort > '(3 8 1 4 2 5 6))))
	)])
      (display-results correct answers equal?)))


(define (test-subst-leftmost)
  (let ([correct '(
		     (((a b (c () (d new (f g)) h)) i))
		     )]
	[answers 
	 (list
	 (eval-one-exp '
	  (letrec (
		   [apply-continuation  (lambda (k . list-of-values)
					  (apply k list-of-values))]
		   [subst-left-cps
		    (lambda (new old slist changed unchanged)
		      (let loop ([slist slist] 
				 [changed changed] 
				 [unchanged unchanged])
			(cond
			 [(null? slist) (apply-continuation unchanged)]
			 [(symbol? (car slist))
			  (if (eq? (car slist) old)
			      (apply-continuation changed (cons new (cdr slist)))
			      (loop (cdr slist)
				    (lambda (changed-cdr)
				      (apply-continuation changed 
							  (cons (car slist) changed-cdr)))
				    unchanged))]
			 [else 
			  (loop (car slist)
				(lambda (changed-car)
				  (apply-continuation changed 
						      (cons changed-car (cdr slist))))
				(lambda () 
				  (loop (cdr slist)
					(lambda (changed-cdr)
					  (apply-continuation changed 
							      (cons (car slist) changed-cdr)))
					unchanged)))])))])
	    (let ([s '((a b (c ()  (d e (f g)) h)) i)])
	      (subst-left-cps 'new 'e s
			      (lambda (changed-s)
				(subst-left-cps 'new 'q s 
						(lambda (wont-be-changed) 'whocares)
						(lambda () (list changed-s))))
			      (lambda () "It's an error to get here"))))))])
    (display-results correct answers equal?)))




;-----------------------------------------------

(define display-results
  (lambda (correct results test-procedure?)
     (display ": ")
     (pretty-print 
      (if (andmap test-procedure? correct results)
          'All-correct
          `(correct: ,correct yours: ,results)))))


(define sequal?-grading
  (lambda (l1 l2)
    (cond
     ((null? l1) (null? l2))
     ((null? l2) (null? l1))
     ((or (not (set?-grading l1))
          (not (set?-grading l2)))
      #f)
     ((member (car l1) l2) (sequal?-grading
                            (cdr l1)
                            (rember-grading
                             (car l1)
                             l2)))
     (else #f))))

(define set?-grading
  (lambda (s)
    (cond [(null? s) #t]
          [(not (list? s)) #f]
          [(member (car s) (cdr s)) #f]
          [else (set?-grading (cdr s))])))

(define rember-grading
  (lambda (a ls)
    (cond
     ((null? ls) ls)
     ((equal? a (car ls)) (cdr ls))
     (else (cons (car ls) (rember-grading a (cdr ls)))))))

(define set-equals? sequal?-grading)

(define find-edges  ; e know that this node is in the graph before we do the call
  (lambda (graph node)
    (let loop ([graph graph])
      (if (eq? (caar graph) node)
	  (cadar graph)
	  (loop (cdr graph))))))

;; Problem 8  graph?
(define set?  ;; Is this list a set?  If not, it is not a graph.
  (lambda (list)
    (if (null? list) ;; it's an empty set.
	#t
	(if (member (car list) (cdr list))
	    #f
	    (set? (cdr list))))))


(define graph?
  (lambda (obj)
    (and (list? obj)
	 (let ([syms (map car obj)])
	   (and (set? syms)
		(andmap symbol? syms)
		(andmap (lambda (x)
			  (andmap (lambda (y) (member y (remove (car x) syms)))
				  (cadr x)))
			obj))))))
    
(define graph-equal?
  (lambda (a b)
    (and
     (graph? a) 
     (graph? b)
     (let ([a-nodes (map car a)]
	   [b-nodes (map car b)])
       (and 
	(set-equals? a-nodes b-nodes)
	    ; Now  See if the edges from each node are equivalent in the two graphs.
	(let loop ([a-nodes a-nodes])
	  (if (null? a-nodes)
	      #t
	      (let ([a-edges (find-edges a (car a-nodes))]
		    [b-edges (find-edges b (car a-nodes))])
		(and (set-equals? a-edges b-edges)
		     (loop (cdr a-nodes)))))))))))

(define (test-graph-equal)
  (list
   (graph-equal? '((a (b)) (b (a))) '((b (a)) (a (b))))
   (graph-equal? '((a (b c d)) (b (a c d)) (c (a b d)) (d (a b c)))
		 '((b (a c d)) (c (a b d)) (a (b d c)) (d (b a c))))
   (graph-equal? '((a ())) '((a ())))
   (graph-equal? '((a (b c)) (b (a c)) (c (a b))) '((a (b c)) (b (a c)) (c (a b))))
   (graph-equal? '() '())
   ))



(define g test-graph-equal)
	   
	  
     



;You can run the tests individually, or run them all
;#by loading this file (and your solution) and typing (r)

(define (run-all)
  (display 'basics) 
  (test-basics)
  (display 'answers-are-sets) 
  (test-answers-are-sets)
  (display 'additional) 
  (test-additional)
  (display 'subst-leftmost) 
  (test-subst-leftmost)
)

(define r run-all)