;;; SLtests2.ss

(define data11
  (lambda (homer)
    (reset-rules!)
    (printf "Setting up rules ...~n")
    (<- () (painter rubens))
    (<- (x) (painter ,x)
      (hungry ,x)
      (smells-of ,x turpentine))
    (<- (x) (hungry ,x)
      (disj (conj (gaunt ,x) (cut!))
	(eats-ravenously ,x)))
    (<- () (hungry foobar))
    (<- () (smells-of foobar turpentine))
    (<- (x f)
      (eats ,x ,f)
      (disj
	(conj (hungry ,x) (been-working-on-511 ,x) (cut!))
	(conj (tasty ,f) (gourmet ,x))
	(glutton ,x)))
    
    (<- (anything) (tasty ,anything))   ;Anything tastes great.
  
    (<- () (glutton ,homer))		;As In Simpson!
    
    (<- (ys) (append () ,ys ,ys))
    (<- (x xs ys zs) (append (,x . ,xs) ,ys (,x . ,zs))
      (append ,xs ,ys ,zs))
    
    (<- (x) (all-elements ,x ()))
    (<- (x rest) (all-elements ,x (,x . ,rest))
      (all-elements ,x ,rest))
    
    (<- (x rest) (member ,x (,x . ,rest)))
    (<- (x rest _) (member ,x (,_ . ,rest))
      (member ,x ,rest))
    
    (<- (_) (cara (a ,_))) ;Does the 2-element list start with a    
    ))

(define test11
  (lambda ()
    (data11 'homer)))

(define test12
  (lambda ()
    (with-inference (x) (eats ,x spinach)
      (display x)
      (newline))))

(define test13
  (lambda ()
    (with-inference (x) (painter ,x)
      (display x) (newline))))

(define test14
  (lambda ()
    (logic-system
      (<- () (gaunt giraffe))
      (<- () (been-working-on-511 giraffe))
      (<- () (gourmet we-dont-care-we-shouldnt-see-him))
      (<- () (eats-ravenously you-should-never-see-this))
      (with-inference (x y) (eats ,x ,y)
	(printf "~a eats ~b~n"
	  x
	  (if (eq? '<anything> y)
	    'anything
	    y))))))

(define test15
  (lambda ()
    (logic-system
      (<- () (eats monster bad-children))
      (<- () (eats warhol  candy))
      (with-inference (x y) (eats ,x ,y)
                      (printf "~a eats ~a ~n" x
                              (if (eq? '<anything> y)
                                  'everything
                                  y))))))


(define test16
  (lambda ()
    (logic-system
      (<- (x) (ordered (,x)))
      (<- (x y ys)
	(ordered (,x ,y . ,ys))
          (scheme (x y) (<= x y))
          (ordered (,y . ,ys)))
      (with-inference ()
	(ordered (1 2 3))
	(printf "Ordered~n")))))

(define test17
  (lambda ()
    (logic-system
      (<- () (factorial 0 1))
      (<- (n f n1 f1)
	(factorial ,n ,f)
          (scheme (n) (> n 0))
          (is (n n1) ,n1 (- n 1))
          (factorial ,n1 ,f1)
          (is (f n f1) ,f (* n f1)))
      (with-inference (n)
	(factorial 5 ,n)
	(printf "The factorial of 5 is ~a~n" n)))))

(define test18
  (lambda ()
    (with-inference ()
      (neg (painter homer))
      (printf "Ha! Ha! Imagine that!~n"))))

(define test-vector
  (let ((vec
	  (vector test11 test12 test13 test14 test15 test16 test17 test18
	    )))
    (lambda (i)
      (if (< i (vector-length vec))
	(vector-ref vec i)
	#f))))

(define test-all
  (lambda ()
    (let ((k #f))
      (fluid-let
	((abort (lambda (v) (display v) (newline) (k (void)))))
	(fluid-let ((offline-mode #t))
	  (let ((i 0))
	    (let loop ()
	      (let ((t (test-vector i)))
		(if t
		  (begin
		    (printf "~nRunning test~a:~n" i)
		    (call/cc (lambda (c)
			       (set! k c)
			       (t)))
		    (set! i (add1 i))
		    (loop)))))))))))