;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/mag)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/%math.c)

(exported
  (dg contagious-type (<num> <num> => (t< <num>)))
  (dg contagious-call (<fun> <num> <num> => <any>))
  (dg + (<num> <num> => <num>))
  (dg - (<num> <num> => <num>))
  (df 1+ (<num> => <num>))
  (df 1- (<num> => <num>))
  (dg * (<num> <num> => <num>))
  (dg / (<num> <num> => <num>))
  (dg sin (<num> => <num>))
  (dg cos (<num> => <num>))
  (dg tan (<num> => <num>))
  (dg sinh (<num> => <num>))
  (dg cosh (<num> => <num>))
  (dg tanh (<num> => <num>))
  (dg asin (<num> => <num>))
  (dg acos (<num> => <num>))
  (dg atan (<num> => <num>))
  (dg atan2 (<num> <num> => <num>))
  (dg sqrt (<num> => <num>))
  (dg log (<num> => <num>))
  (dg logn (<num> <num> => <num>))
  (dg floor (<num> => <int>))
  (dg ceil (<num> => <int>))
  (dg round (<num> => <int>))
  (dg round-to (<num> <int> => <num>))
  (dg trunc (<num> => <int>))
  (dg floor/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>)))
  (dg ceil/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>)))
  (dg round/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>)))
  (dg trunc/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>)))
  (dg div (<num> <num> => <num>))
  (dg mod (<num> <num> => <num>))
  (dg mod+ (<num> <num> <num> => <num>))
  (dg mod- (<num> <num> <num> => <num>))
  modincf
  moddecf
  (dg rem (<num> <num> => <num>))
  (dg pow (<num> <num> => <num>))
  (dg exp (<num> => <num>))
  (dg pos? (<num> => <log>))
  (dg zero? (<num> => <log>))
  (dg neg? (<num> => <log>))
  (dg neg (<num> => <num>))
  (dg abs (<num> => <num>))
  (dg #| (<int> <int> => <int>))
  (dg ^ (<int> <int> => <int>))
  (dg & (<int> <int> => <int>))
  (dg ~ (<int> => <int>))
  (dg bit? (<int> <int> => <log>))
  (dg >> (<int> <int> => <int>))
  (dg even? (<int> => <log>))
  (dg odd? (<int> => <log>))
  (dg >>> (<int> <int> => <int>))
  (dg << (<int> <int> => <int>))
  (dg isqrt (<int> => <int>))
  (dg power-of-two-ceil (<int> => <int>))
  (dg flo-bits (<flo> => <int>))
  $pi
  $e
)

(dm contagious-call (f|<fun> x|<num> y|<num> => <any>)
  (def type (contagious-type x y))
  (f (as type x) (as type y)))

(dm = (x|<num> y|<num> => <log>)
  (contagious-call == x y))

(dm < (x|<num> y|<num> => <log>)
  (contagious-call < x y))

(dm + (x|<num> y|<num> => <num>)
  (contagious-call + x y))

(df (1+ inline) (x|<num> => <num>) (+ x 1))

(dm - (x|<num> y|<num> => <num>)
  (contagious-call - x y))

(df (1- inline) (x|<num> => <num>) (- x 1))

(dm * (x|<num> y|<num> => <num>)
  (contagious-call * x y))

(dm / (x|<num> y|<num> => <num>)
  (contagious-call / x y))

(dm atan2 (y|<num> x|<num> => <num>)
  (contagious-call atan2 y x))

(dm logn (x|<num> b|<num> => <num>)
  (contagious-call logn x b))

(dm floor (x|<num> => <int>)
  (elt (contagious-call floor/ x 1) 0))

(dm ceil (x|<num> => <int>)
  (elt (contagious-call ceil/ x 1) 0))

(dm round (x|<num> => <int>)
  (elt (contagious-call round/ x 1) 0))

(dm round-to (x|<num> n|<int> => <num>)
  (if (= n 0)
      (round x)
      (let ((f (pow 10.0 n)))
        (x (/ (round (* x f)) f)))))

(dm trunc (x|<num> => <int>)
  (elt (contagious-call trunc/ x 1) 0))

(dm floor/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>))
  (def (tup (integer <int>) (remainder <num>)) (trunc/ real divisor))
  (if (and (not (zero? remainder))
           (if (neg? divisor)
               (pos? real)
               (neg? real)))
      (tup (- integer 1) (+ remainder divisor))
      (tup integer remainder)))

(dm ceil/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>))
  (def (tup (integer <int>) (remainder <num>)) (trunc/ real divisor))
  (if (and (not (zero? remainder))
           (if (neg? divisor)
               (neg? real)
               (pos? real)))
      (tup (+ integer 1) (- remainder divisor))
      (tup integer remainder)))

(dm round/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>))
  (def (tup (integer <int>) (remainder <num>)) (trunc/ real divisor))
  (def threshold|<num> (/ (abs divisor) 2.0))
  (if (or (> remainder threshold) 
          (and (= remainder threshold) (odd? integer)))
      (if (neg? divisor)
          (tup (- integer 1) (+ remainder divisor))
          (tup (+ integer 1) (- remainder divisor)))
      (if (let ((minus-threshold (neg threshold)))
            (or (< remainder minus-threshold)
                (and (= remainder minus-threshold) (odd? integer))))
          (if (neg? divisor)
              (tup (+ integer 1) (- remainder divisor))
              (tup (- integer 1) (+ remainder divisor)))
          (tup integer remainder))))

(dm trunc/ (real|<num> divisor|<num> => (tup x|<int> rem|<num>))
  (contagious-call trunc/ real divisor))

(dm div (x|<num> y|<num> => <num>)
  (%telt (trunc/ x y) (%iu 0)))

(dm mod (real|<num> divisor|<num> => <num>)
  (def (tup _ (remainder <num>)) (floor/ real divisor))
  remainder)

(dm (mod+ inline) (i|<num> j|<num> n|<num> => <num>)
  (mod (+ i j) n))

(dm (mod- inline) (i|<num> j|<num> n|<num> => <num>)
  (mod (- i j) n))

(ds modincf (,place ,max)
  `(opf ,place (mod+ _ 1 ,max)))

(ds moddecf (,place ,max)
  `(opf ,place (mod- _ 1 ,max)))

(dm rem (real|<num> divisor|<num> => <num>)
  (def (tup _ (remainder <num>)) (trunc/ real divisor))
  remainder)

(dm pow (base|<num> n|<num> => <num>)
  (contagious-call pow base n))

(dm (exp inline) (n|<num> => <num>)
  (pow $e n))

(dm (pos? inline) (x|<num> => <log>)
  (> x 0))

(dm (zero? inline) (x|<num> => <log>)
  (= x 0))

(dm (neg? inline) (x|<num> => <log>)
  (< x 0))

(dm (neg inline) (x|<num> => <num>)
  (- 0 x))

(dm (abs inline) (x|<num> => <num>)
  (if (neg? x) (neg x) x))

(dm to-str (x|<num> => <str>)
  (num-to-str x))

;;; <INT>

(dm contagious-type (x|<int> y|<int> => (t< <int>))
  <int>)

(dm contagious-type (x|<flo> y|<flo> => (t= <flo>))
  <flo>)

(dm contagious-type (x|<int> y|<flo> => (t= <flo>))
  <flo>)

(dm contagious-type (x|<flo> y|<int> => (t= <flo>))
  <flo>)

(dm (== inline) (x|<fixnum> y|<fixnum> => <log>)
  (%bb (%i= (%iu x) (%iu y))))

(dm (< inline) (x|<fixnum> y|<fixnum> => <log>)
  (%bb (%i< (%iu x) (%iu y))))

(dm (+ inline) (x|<fixnum> y|<fixnum> => <int>)
  (%ib (%i+ (%iu x) (%iu y))))

(dm (- inline) (x|<fixnum> y|<fixnum> => <int>)
  (%ib (%i- (%iu x) (%iu y))))

(dm (* inline) (x|<fixnum> y|<fixnum> => <int>)
  (%ib (%i* (%iu x) (%iu y))))

(dm (/ inline) (x|<int> y|<int> => <int>)
  (arithmetic-error "No int divide, consider trunc/"))

(dm (floor inline) (x|<int> => <int>) x)

(dm (ceil inline) (x|<int> => <int>) x)

(dm (round inline) (x|<int> => <int>) x)

(dm (trunc inline) (x|<int> => <int>) x)

(dm trunc/ (x|<fixnum> y|<fixnum> => (tup quo|<fixnum> rem|<fixnum>))
  (def result (%ib (%it/ (%iu x) (%iu y))))
  (tup result (- x (* result y))))

(dm mod (x|<fixnum> y|<fixnum> => <fixnum>)
  (def res (%ib (%im (%iu x) (%iu y))))
  (if (< res 0)
      (if (> y 0)
          (+ res y)
          (- res y))
      res))

(dm pow (x|<fixnum> n|<fixnum> => <num>)
  (cond
    ((neg? n) (/ 1 (pow x (neg n))))
    ((= x 2)  (<< 1 n))
    ((neg? x) (if (odd? n) (neg (pow (neg x) n)) (pow (neg x) n)))
    (#t
     (rep loop ((x|<fixnum> (if (> n 1) (* x x) x))
                (p|<fixnum> (>> n 1))
                (y|<fixnum> (if (odd? n) x 1)))
       (if (zero? p)
           y
           (loop (if (> p 1) (* x x) x)
                 (>> p 1)
                 (if (odd? p) (* x y) y)))))))

(dm (#| inline) (x|<fixnum> y|<fixnum> => <fixnum>)
  (%ib (%iv (%iu x) (%iu y))))

(dm (^ inline) (x|<fixnum> y|<fixnum> => <fixnum>)
  (%ib (%i^ (%iu x) (%iu y))))

(dm (& inline) (x|<fixnum> y|<fixnum> => <fixnum>)
  (%ib (%i& (%iu x) (%iu y))))

(dm (~ inline) (x|<fixnum> => <fixnum>)
  (%ib (%i! (%iu x))))

(dm (bit? inline) (o|<fixnum> x|<fixnum> => <log>)
  (%bb (%i? (%iu o) (%iu x))))

(dm (even? inline) (x|<fixnum> => <log>)
  (zero? (& x 1)))

(dm (odd? inline) (x|<fixnum> => <log>)
  (not (even? x)))

(dm (>> inline) (x|<fixnum> a|<fixnum> => <fixnum>)
  (%ib (%i>> (%iu x) (%iu a))))

(dm (>>> inline) (x|<fixnum> a|<fixnum> => <fixnum>)
  (%ib (%i>>> (%iu x) (%iu a))))

(dm (<< inline) (x|<fixnum> a|<fixnum> => <int>)
  (%ib (%i<< (%iu x) (%iu a))))

(dm power-of-two-ceil (x|<int> => <int>)
  (rep search ((po2|<int> 1))
    (if (> po2 x)
        po2
        (search (+ po2 po2)))))

;;; FLO

(dl %fi2f)
(dl %f=)
(dl %f<)
(dl %f+)
(dl %f*)
(dl %f-)
(dl %f/)
(dl %ft)
(dl %ft/)
(dl %ff)
(dl %fc)
(dl %flo-bits)
(dl %fpow)
(dl %flog)
(dl %fsqrt)
(dl %fsin)
(dl %fcos)
(dl %ftan)
(dl %fasin)
(dl %facos)
(dl %fatan)
(dl %fatan2)
(dl %fsinh)
(dl %fcosh)
(dl %ftanh)

(df flo-bits (x|<flo> => <int>)
  (%ib (%flo-bits (%fu x))))

(dm as ((_ (t= <flo>)) x|<fixnum> => <flo>)
  (%fb (%fi2f (%iu x))))

(dm (== inline) (x|<flo> y|<flo> => <log>)
  (%bb (%f= (%fu x) (%fu y))))

(dm (< inline) (x|<flo> y|<flo> => <log>)
  (%bb (%f< (%fu x) (%fu y))))

(dm (+ inline) (x|<flo> y|<flo> => <flo>)
  (%fb (%f+ (%fu x) (%fu y))))

(dm (- inline) (x|<flo> y|<flo> => <flo>)
  (%fb (%f- (%fu x) (%fu y))))

(dm (* inline) (x|<flo> y|<flo> => <flo>)
  (%fb (%f* (%fu x) (%fu y))))

(dm (/ inline) (x|<flo> y|<flo> => <flo>)
  (%fb (%f/ (%fu x) (%fu y))))

(dm trunc/ (x|<flo> y|<flo> => (tup z|<fixnum> rem|<flo>))
  (def divided (/ x y))
  (def result  (%ib (%ft (%fu divided))))
  (tup result (* y (- divided (as <flo> result)))))

(dm pow (x|<flo> n|<flo> => <flo>)
  (def res (%fb (%fpow (%fu (abs x)) (%fu n))))
  (if (and (neg? x) (odd? n)) (neg res) res))

(dv $pi 3.14159265)
(dv $e  2.71828182)

(dm isqrt (x|<int> => <int>)
  (round (sqrt (as <flo> x))))

;; (ct (dv cat-sym make-sym))

(ds def-unary-trans (,name (,param) ,@prefix)
  (let ((%fp (cat-sym "%f" name)))
    `(seq (dg ,name ((,param <num>) => <num>))
          (dm ,name ((,param <int>) => <flo>) 
            ,@prefix (,name (as <flo> ,param)))
          (dm ,name ((,param <flo>) => <flo>)
            ,@prefix (%fb (,%fp (%fu ,param)))))))

(def-unary-trans sqrt (x)
  (when (neg? x) (arithmetic-error "SQRT would produce complex number")))

(def-unary-trans log (x))
(def-unary-trans sin (x))
(def-unary-trans cos (x))
(def-unary-trans tan (x))
(def-unary-trans sinh (x))
(def-unary-trans cosh (x))
(def-unary-trans tanh (x))
(def-unary-trans asin (x)
  (when (neg? x) (arithmetic-error "SQRT would produce complex number")))
(def-unary-trans acos (x)
  (when (neg? x) (arithmetic-error "SQRT would produce complex number")))
(def-unary-trans atan (x))

(dg atan2 (y|<num> x|<num> => <num>))
(dm atan2 (y|<flo> x|<flo> => <flo>) 
  (%fb (%fatan2 (%fu y) (%fu x))))
(dm atan2 (y|<flo> x|<flo> => <flo>) 
  (%fb (%fatan2 (%fu y) (%fu x))))

(dm logn (x|<num> b|<num> => <num>) 
  (/ (log x) (log b)))

;; from strings.goo
(need-implementation
  num-to-str)
