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

(effects-checked? #t)

(run-tests
  "EFFECT-CHECKERS"
  (((query-checker ('odd? odd?) ('even? even?))
    (lambda (n) (values n (+ n 1)))) 3)
  (condition-case (((query-checker ('odd? odd?) ('even? even?))
                    (lambda (n) (values n (+ n 1)))) 4)
    ((exn) #t))
  (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)
  "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) #t))
  "UNARY METHODS"
  (define 1+-number?
    (method ('1+-number? add1 (query-checker ('fixnum? fixnum?))
                  "add1" "violates postcondition")
            ('number? number?)))
  (define 1+-integer?
    (method ('1+-integer? add1 (query-checker ('integer? integer?))
                  "add1")
            ('integer?negative? integer? negative?)))
  (define 1+-fixnum?
    (method ('1+-fixnum? (cut fx+ <> 1) (query-checker ('fixnum? fixnum?)) "fx1+")
            ('fixnum? fixnum?)))
  (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 ('even? even?)) "+" "violates postcondition")
            ('odd? odd?)
            ('even? even?)))
  (define fx+-fixnum?-fixnum?
    (method ('fx+-fixnum?-fixnum? fx+ (query-checker ('fixnum? fixnum?)) "fx+")
            ('fixnum? fixnum?)
            ('fixnum? fixnum?)))
  (define +-fixnum?-number?
    (method ('fx+-fixnum?-number? + (query-checker ('number? number?)) "+")
            ('fixnum? fixnum?)
            ('number? number?)))
  (method? +-odd?-even?)

  "VARIADIC METHODS"
  (define *-list-of-number?
    (method #t
            ('*-list-of-number? * (query-checker ('odd? odd?)) "*" "postcondition")
            ('list-of-number? (list-of? number?))))
  (define *-list-of-integer?
    (method #t
            ('*-list-of-integer? * (query-checker ('integer? integer?)) "*")
            ('list-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 (fx** arg . args)
    (let loop ((args args))
      (if (null? args)
        arg
        (apply fx** (fx* arg (car args)) (cdr args)))))
  (fx= (fx** 1 2 3 4 5) 120)
  (define *-number?-list-of-number?
    (method #t
            ('*-number?-list-of-number? * (query-checker ('number? number?)) "*")
            ('number? number?)
            ('list-of-number? (list-of? number?))))
  (= (*-number?-list-of-number? 1 2 3 4 5) 120)
  (define *-fixnum?-list-of-fixnum?
    (method #t
            ('*-fixnum?-list-of-fixnum? fx**
             (query-checker ('fixnum?  fixnum?)) "fx**")
            ('fixnum? fixnum?)
            ('list-of-fixnum? (list-of? fixnum?))))
  (define *-fixnum?-list-of-number?
    (method #t
            ('*-fixnum?-list-of-fixnum? * (query-checker ('number? number?)) "*")
            ('fixnum? fixnum?)
            ('list-of-number? (list-of? number?))))
)

(run-tests
  "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? 'number?)
  (multi-method? 1+)
  (not (multi-method-variadic? 1+))
  (fx= (multi-method-arity 1+) 1)
  (equal? (multi-method-keys 1+) '(fixnum? integer?negative? number?))
  (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? 'odd?)
  (multi-method-insert! add fx+-fixnum?-fixnum? 'fixnum? 'number?)
  (not (multi-method-variadic? add))
  (equal? (multi-method-keys add) '(fixnum? odd?))
  (equal? (multi-method-keys add 'fixnum?) '(fixnum? number?))
  (equal? (multi-method-keys add 'odd?) '(even?))
  (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? 'number?)
  (multi-method-insert! product *-fixnum?-list-of-number? 'fixnum?)
  (equal? (multi-method-keys product) '(fixnum? number?))
  (equal? (multi-method-keys product 'fixnum?)
          '(list-of-fixnum?  list-of-number?))
  (equal? (multi-method-keys product 'number?) '(list-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)
  )