(load "../common")

(defmacro mtest-pif (:form f . pairs)
  (unless (evenp (len pairs))
    (compile-error f "even number of arguments required"))
  ^(mtest ,*(mappend (aret ^((parse-infix ',@1) ,@2)) (tuples 2 pairs))))

(mtest-pif
  nil nil
  (-) :error
  (=) :error
  (--) :error
  (++) :error
  (a -) :error
  (a =) :error
  (a) a
  (= b) (identity b)
  (++ a) (inc a)
  (-- a) (dec a)
  (= (-)) (identity @(-))
  (++ (-)) (inc @(-))
  (-- (-)) (dec @(-)))

(defmacro mtest-pif-syms (:form f (var syms) . pairs)
  (unless (evenp (len pairs))
    (compile-error f "even number of arguments required"))
  ^(each ((,var ',syms))
     (mvtest ,*(mappend (aret ^((parse-infix ,@1) ,@2)) (tuples 2 pairs)))))

(mtest-pif-syms (fn (abs signum isqrt square zerop plusp minusp evenp oddp
                     sin cos tan asin acos atan log log2 log10 exp
                     sqrt width logcount cbrt erf erfc exp10 exp2 expm1
                     gamma lgamma log1p logb nearbyint rint significand
                     tgamma tofloat toint trunc floor ceil round lognot))
  ^(a ,fn) :error
  ^(,fn) :error
  ^(,fn b) ^(,fn b)
  ^(,fn (:)) ^@(,fn (:))
  ^(,fn (: :)) ^@(,fn (: :))
  ^(,fn a + b) ^(,fn (+ a b))
  ^(,fn ,fn ,fn a + b) ^(,fn (,fn (,fn (+ a b))))
  ^(,fn a + b + ,fn b + c) ^(+ (,fn (+ a b)) (,fn (+ b c)))
  ^(,fn a + b + - ,fn b + c) ^(+ (,fn (+ a b)) (- (,fn (+ b c))))
  ^(,fn a + b + ,fn - b + c) ^(+ (,fn (+ a b)) (,fn (+ (- b) c))))

(mtest-pif
  (a + b) (+ a b)
  (a + b + c) (+ (+ a b) c)
  (a + b * c) (+ a (* b c))
  (a * b + c) (+ (* a b) c)
  (a ** b * c + d) (+ (* (expt a b) c) d)
  (a ** b * c + d) (+ (* (expt a b) c) d)
  (x + a ** b * c + d) (+ (+ x (* (expt a b) c)) d)
  (x + a ** b ++ * c + d) (+ (+ x (* (expt a (pinc b)) c)) d)
  (x + -- a ** b ++ * c + d) (+ (+ x (* (expt (dec a) (pinc b)) c)) d))

(mtest-pif
  ([i]) @[i]
  (a[i]) @[a (i)]
  (a[i][j]) @[[a (i)] (j)]
  (a[i][j][k]) @[[[a (i)] (j)] (k)])

(mtest-pif
  (x ** a[i][j][k]) (expt x @[[[a (i)] (j)] (k)])
  (x ** a[i][j][k] ++) (expt x (pinc @[[[a (i)] (j)] (k)]))
  (x ** -- a[i][j][k]) (expt x (dec @[[[a (i)] (j)] (k)]))
  (x ** -- a[i + y][j ++][-- k]) (expt x (dec @[[[a (i + y)] (j ++)] (-- k)])))

(ifx
  (defun quadratic-roots (a b c)
    (let ((d (sqrt b * b - 4 * a * c)))
      (list ((- b + d) / 2 * a)
            ((- b - d) / 2 * a)))))

(mtest
  (quadratic-roots 1 0 -4) (2.0 -2.0)
  (quadratic-roots 1 2 1) (-1.0 -1.0))

(defvar *compiling* t)

(compile-only
  (set *compiling* nil))

(defmacro unless-compiling (form)
  (unless *compiling* form))

(ifx
  (mtest
    (1 cons 2) (1 . 2)
    (1 list* 2 3) (1 2 . 3)
    (1 cons 2 cons 3) (1 2 . 3)
    (1 cons 2 * 2 + 3 * 3) (1 . 13)
    (1 cons 2 * 2 + 3 * 3 cons 29) :error
    (1 cons (2 * 2 + 3 * 3) cons 29) (1 13 . 29)
    (1 cons 2 list* (2 + 2) (3 + 3) nil) (1 2 4 6))

  (mtest
    (list 1 2) (1 2)
    (list 2 + 2) (4)
    (list list 2 + 2) ((4)))

  (unless-compiling
    (test
      (list list 2 2) :error)))

(defun fft (data nn isign)
  (ifx
    (let (n mmax m j istep
          wtemp wpr wpi wr wi theta
          tempr tempi (data (copy data)))
      (n := nn << 1)
      (j := 1)
      (for ((i 1)) ((i < n)) ((i += 2))
        (when (j > i)
          (swap (data[j]) (data[i]))
          (swap (data[j + 1]) (data[i + 1])))
        (m := nn)
        (while (2 <= m < j)
          (j -= m)
          (m >>= 1))
        (j += m))
      (mmax := 2)
      (while (n > mmax)
        (istep := mmax << 1)
        (theta := isign * ((2 * %pi%) / mmax))
        (wtemp := sin 0.5 * theta)
        (wpr := - 2.0 * wtemp * wtemp)
        (wpi := sin theta)
        (wr := 1.0)
        (wi := 0.0)
        (for ((m 1)) ((m < mmax)) ((m += 2))
          (for ((i m)) ((i <= n)) ((i += istep))
            (j := i + mmax)
            (tempr := wr * data[j] - wi * data[j + 1])
            (tempi := wr * data[j + 1] + wi * data[j])
            (data[j] := data[i] - tempr)
            (data[j + 1] := data[i + 1] - tempi)
            (data[i] += tempr)
            (data[i + 1] += tempi))
          (wr := (wtemp := wr) * wpr - wi * wpi + wr)
          (wi := wi * wpr + wtemp * wpi + wi))
        (mmax := istep))
      data)))

(msstest
  (fft #(nil 0.0 0.0 0.0 0.0) 2 1) #(nil 0.0 0.0 0.0 0.0)
  (fft #(nil 1.0 1.0 1.0 1.0) 2 1) #(nil 2.0 2.0 0.0 0.0)
  (fft #(nil 0 1 0 2 0 3 0 4) 4 1) #(nil 0.0 10.0 2.0 -2.0 0.0 -2.0 -2.0 -2.0))

(msstest
  (map (lop / 4) #(10 20 30)) #(2.5 5.0 7.5))

(defmacro mtest-ifx (:form f . pairs)
  (unless (evenp (len pairs))
    (compile-error f "even number of arguments required"))
  ^(mtest ,*(mappend (aret ^((expand '(ifx ,@1)) ,@2)) (tuples 2 pairs))))

(mtest-pif
  (a eq b) (eq a b)
  (a nequal b) (nequal a b)
  (a = b) (= a b)
  (a eq b eq c) (eq a (eq b c))
  (a nequal b nequal c) (nequal a (nequal b c))
  (a = b = c) (= a (= b c))
  (a eq b = c = d != e
     = f = g < h < i < j) (eq a
                              (= b
                                 (= c
                                    (/= d
                                        (= e
                                           (= f
                                              (< g
                                                 (< h
                                                    (< i
                                                       j))))))))))
(mtest-ifx
  (a eq b) (eq a b)
  (a nequal b) (nequal a b)
  (a = b) (= a b)
  (a eq b eq c) (and (eq a b) (eq b c))
  (a nequal b nequal c) (and (nequal a b) (nequal b c))
  (a = b = c) (= a b c)
  (a eq b = c = d != e = f = g < h < i < j) (and (eq a b) (= b c d) (/= d e)
                                                 (= e f g) (< g h i j)))

(mtest-pif
  (a + b) (+ a b)
  (a + b + c) (+ (+ a b) c)
  (a + b + c + d) (+ (+ (+ a b) c) d)
  (a * b * c + d * e + e * f * g) (+ (+ (* (* a b) c)
                                        (* d e))
                                     (* (* e f) g)))

(mtest-ifx
  (a + b) (+ a b)
  (a + b + c) (+ a b c)
  (a + b + c + d) (+ a b c d)
  (a * b * c + d * e + e * f * g) (+ (* a b c) (* d e) (* e f g)))

(mtest-ifx
  (~ a) (lognot a)
  (~ a | ~ b) (logior (lognot a) (lognot b)))