(require-library multi-methods simple-tests)
(import methods multi-methods simple-tests)

(effects-checked? #t)

(run-tests
  "EFFECT-CHECKERS"
  (= (((no-checker "doc") add1) 5) 6)
  (= (((query-checker (lambda (n)
                         (lambda (result)
                           (= result (+ n 1))))
                      '(= result (+ n 1)))
       add1) 5) 6)
  (define pair (cons 1 2))
  (((command-checker ((lambda (pair val)
                        (values (car pair)
                                (lambda (old new)
                                  (equal? (car pair) new))))
                      '(equal? (car pair) new)))
    (extend-procedure set-car! 'set-car!))
    pair 10)
  (= (((no-checker "doc") add1) 5) 6)
  "POSTCONDITION VIOLATED:"
  (condition-case
    (((command-checker ((lambda (pair val)
                          (values (car pair)
                                  (lambda (old new)
                                    (equal? (car pair) (add1 new)))))
                        '(equal? (car pair) new)))
      (extend-procedure set-car! 'set-car!))
     pair 10)
    ((exn) "postcondition violated"))
  (condition-case
    (((query-checker (lambda (n)
                        (lambda (result)
                          (= result n)))
                     '(= result n))
      add1) 5)
    ((exn) "postcondition violated"))
  "THUNK METHOD"
  (define foo
    (method ('foo
             (lambda () 'foo)
             (query-checker
               (lambda ()
                  (lambda (result)
                    (and (symbol? result) (eq? result 'foo))))
               '(and (symbol? result) (eq? result 'foo))))))
  (method? foo)
  (eq? (foo) 'foo)
  "UNARY METHODS"
  (define 1+-number?
    (method ('1+-number?
             add1
             (query-checker
               (lambda (n)
                  (lambda (result)
                    (and (fixnum? result) (= result (+ n 1)))))
               '(and (fixnum? result) (= result (+ n 1)))))
            ('1number? number?)))
  (fx= (1+-number? 5) 6)
  (condition-case
    (= (1+-number? 5.0) 6.0)
    ((exn) "postcondition violated"))
  (define 1+-integer?
    (method ('1+-integer?
             add1
             (query-checker
               (lambda (n)
                  (lambda (result)
                    (and (integer? result) (= result (+ n 1)))))
               '(and (integer? result) (= result (+ n 1)))))
            ('1integer?negative? integer? negative?)))
  (define 1+-fixnum?
    (method ('1+-fixnum? 
             (cut fx+ <> 1)
             (query-checker
               (lambda (n)
                  (lambda (result)
                    (and (fixnum? result) (fx= result (fx+ n 1)))))
               '(and (fixnum? result) (fx= result (fx+ n 1)))))
            ('1fixnum? fixnum?)))
  (fx= (1+-fixnum? 5) 6)
  (condition-case
    (= (1+-fixnum? 5.0) 6.0)
    ((exn) "precondition violated"))
  (method? 1+-number?)
  (method? 1+-integer?)
  (eq? (method-name 1+-number?) '1+-number?)
  (not (method? add1))
  (fx= (method-arity 1+-number?) 1)
  (not (method-variadic? 1+-number?))

  "METHODS OF ARITY 2"
  (define +-odd?-even?
    (method ('+-odd?-even?
             +
             (query-checker
               (lambda (x y)
                  (lambda (result)
                    (and (even? result) (= result (+ x y)))))
               '(and (even? result) (= result (+ x y)))))
            ('1odd? odd?)
            ('2even? even?)))
  (define fx+-fixnum?-fixnum?
    (method ('fx+-fixnum?-fixnum?
             fx+
             (query-checker
               (lambda (x y)
                  (lambda (result)
                    (and (fixnum? result) (fx= result (fx+ x y)))))
               '(and (fixnum? result) (fx= result (fx+ x y)))))
            ('1fixnum? fixnum?)
            ('2fixnum? fixnum?)))
  (define +-fixnum?-number?
    (method ('+-fixnum?-number?
             +
             (query-checker
               (lambda (x y)
                  (lambda (result)
                    (and (number? result) (= result (+ x y)))))
               '(and (number? result) (= result (+ x y)))))
            ('1fixnum? fixnum?)
            ('2number? number?)))
  (method? +-odd?-even?)

  "VARIADIC METHODS"
  (define *-list-of-number?
    (method #t
            ('*-list-of-number?
             *
             (query-checker
               (lambda xs
                  (lambda (result)
                    (and (odd? result) (= result (apply * xs)))))
               '(and (odd? result) (= result (apply * xs)))))
            ('1list-of-number? (list-of? number?))))
  (define *-list-of-integer?
    (method #t
            ('*-list-of-integer?
             *
             (query-checker
               (lambda xs
                  (lambda (result)
                    (and (integer? result) (= result (apply * xs)))))
               '(and (integer? result) (= result (apply * xs)))))
            ('1list-of-integer? (list-of? integer?))))
  (method-variadic? *-list-of-integer?)
  (eq? (method-name *-list-of-integer?) '*-list-of-integer?)
  (= (*-list-of-integer? 1 2 3 4 5) 120)
  (= (*-list-of-integer?) 1)
  (condition-case (= (*-list-of-number? 2 3) 6)
    ((exn) "postcondition violated"))

  (define *-number?-list-of-number?
    (method #t
            ('*-number?-list-of-number?
             *
             (query-checker
               (lambda (x . xs)
                  (lambda (result)
                    (and (number? result) (= result (apply * x xs)))))
               '(and (number? result) (= result (apply * x xs)))))
            ('1number? number?)
            ('2list-of-number? (list-of? number?))))
  (= (*-number?-list-of-number? 1 2 3 4 5) 120)
  (define (fx** x . xs)
    (if (null? xs)
      x
      (apply fx** (fx* x (car xs)) (cdr xs))))
  (fx= (fx** 1 2 3 4 5) 120)
  (define *-fixnum?-list-of-fixnum?
    (method #t
            ('*-fixnum?-list-of-fixnum?
             fx**
             (query-checker
               (lambda (x . xs)
                  (lambda (result)
                    (and (fixnum? result) (= result (apply fx** x xs)))))
               '(and (fixnum? result) (= result (apply fx** x xs)))))
            ('1fixnum? fixnum?)
            ('2list-of-fixnum? (list-of? fixnum?))))
  (define *-fixnum?-list-of-number?
    (method #t
            ('*-fixnum?-list-of-number?
             *
             (query-checker
               (lambda (x . xs)
                  (lambda (result)
                    (and (number? result) (= result (apply * x xs)))))
               '(and (number? result) (= result (apply * x xs)))))
            ('1fixnum? fixnum?)
            ('2list-of-number? (list-of? number?))))
  "A MULTI-METHOD OF ARITY 1"
  (define 1+ (multi-method x))
  (multi-method? 1+)
  (not (multi-method-variadic? 1+))
  "INSERT INTO EMPTY TREE"
  (multi-method-insert! 1+ 1+-fixnum?)
  "INSERT AT END (NO SYM)"
  (multi-method-insert! 1+ 1+-number?)
  "INSERT BEFORE NUMBER?"
  (multi-method-insert! 1+ 1+-integer? '1number?)
  (multi-method? 1+)
  (not (multi-method-variadic? 1+))
  (fx= (multi-method-arity 1+) 1)
  (equal? (multi-method-keys 1+)
          '(1fixnum? 1integer?negative? 1number?))
  (fx= (1+ 5) 6)
  (= (1+ -5.0) -4.0)
  "POSTCONDITION VIOLATED"
  (condition-case (= (1+ 5.0) 6.0) ((exn) #t))

  "A MULTIMETHOD OF ARITY 2"
  (define add (multi-method x y))
  (multi-method? add)
  (multi-method-empty? add)
  (fx= (multi-method-arity add) 2) 
  (not (multi-method-variadic? add))
  "INSERTING METHODS"
  (multi-method-insert! add +-odd?-even?)
  (not (multi-method-empty? add))
  (multi-method-insert! add +-fixnum?-number? '1odd?)
  (multi-method-insert! add fx+-fixnum?-fixnum? '1fixnum? '2number?)
  (not (multi-method-variadic? add))
  (equal? (multi-method-keys add) '(1fixnum? 1odd?))
  (equal? (multi-method-keys add '1fixnum?) '(2fixnum? 2number?))
  (equal? (multi-method-keys add '1odd?) '(2even?))
  (multi-method? add)
  "EVALUATING CALLS"
  (fx= (add 1 2) 3)
  (= (add 1 2.0) 3.0)
  "PRECONDITION VIOLATED"
  (condition-case (= (add 2.0 2.0) 4.0)
    ((exn) "precondition violated"))
  "POSTCONDITION VIOLATED"
  (condition-case (= (add 1.0 2.0) 3.0)
    ((exn) "postcondition violated"))

  "A VARIADIC MULTI-METHOD"
  (define product (multi-method x xs))
  (multi-method? product)
  (multi-method-insert! product *-number?-list-of-number?)
  (multi-method-insert! product *-fixnum?-list-of-fixnum? '1number?)
  (multi-method-insert! product *-fixnum?-list-of-number? '1fixnum?)
  (equal? (multi-method-keys product) '(1fixnum? 1number?))
  (equal? (multi-method-keys product '1fixnum?)
          '(2list-of-fixnum?  2list-of-number?))
  (equal? (multi-method-keys product '1number?) '(2list-of-number?))
  (fx= (multi-method-arity product) 2)
  (multi-method-variadic? product)
  "EVALUATING CALLS"
  (fx= (product 1 2 3) 6)
  (= (product 1 2.0 3.0) 6)
  )