;; tests for fsa's

(use-syntax (ice-9 syncase))

(define-syntax asserteq
  (syntax-rules ()
    ((asserteq val1 val2)
     (let ((res1 val1) (res2 val2))
       (if (not (equal? res1 res2))
	 (error "Failed assertion" '(equal? val1 val2) '=> (list 'equal? res1 res2)))))))

(define fsa1
  (let* ((t1 (make-transition 'St1 'a 'St2))
	 (t2 (make-transition 'St2 'b 'St3))
	 (t3 (make-transition 'St3 '(not in a b d e) 'St1))
	 (t4 (make-transition 'St2 '(in d f) 'St4))
	 (t5 (make-transition 'St4 'e 'St5))
	 (trans (list t1 t2 t3 t4 t5)))
    (make-fsa 'St1 '(St2 St5) trans)))

(define fsa2
  (let* ((t1 (make-transition 'St6 'a 'St6))
	 (t2 (make-transition 'St6 'b 'St7))
	 (t3 (make-transition 'St7 '(in b) 'St6))
	 (t4 (make-transition 'St6 '(not . d) 'St8))
	 (trans (list t1 t2 t3 t4)))
    (make-fsa 'St6 '(St6) trans)))

(define (test-fsa fsa rules)
  (let ((comp (fsa-complement fsa)))
    (for-each (lambda (rule)
	      (let ((input (car rule))
		    (result (cadr rule)))
		(display "test ") (display input) (newline)
		(asserteq (not result) (not (not (fsa-match comp input))))
		(asserteq result (not (not (fsa-match fsa input))))))
	    rules)))

(define fsa1-rules '((() #f)
		     ((a) #t)
		     ((b) #f)
		     ((a b) #f)
		     ((a c) #f)
		     ((a b c) #f)
		     ((a b d) #f)
		     ((a b c a) #t)
		     ((a b c d) #f)
		     ((a d) #f)
		     ((a d a) #f)
		     ((a d e) #t)
		     ((a d e e) #f)
		     ((a b c a d e) #t)
		     ((a b c a d) #f)
		     ((a b c a b c a d e) #t)))

(define fsa2-rules '((() #t)
		     ((a) #t)
		     ((b) #f)
		     ((c) #f)
		     ((d) #f)
		     ((a a) #t)
		     ((a b) #f)
		     ((b a) #f)
		     ((b b) #t)
		     ((b c) #f)
		     ((a c) #f)
		     ((a a b) #f)
		     ((a a c) #f)
		     ((a a d) #f)
		     ((a a b b) #t)
		     ((a a b a) #f)
		     ((b b a) #t)
		     ((b b a b) #f)
		     ((b b a a) #t)
		     ((b b b a) #f)
		     ((b b b b) #t)
		     ((b b b b c) #f)
		     ((c d) #f)
		     ((a c d) #f)
		     ((b b c d) #f)))

(test-fsa fsa1 fsa1-rules)
(test-fsa fsa2 fsa2-rules)
;(test-fsa-comb fsa1 fsa2 (append fsa1-rules fsa2-rules))