;; -*-theme-d-*-

;; Copyright (C) 2018 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.


(define-body (standard-library math)

  (define-simple-method = (((nr1 <number>) (nr2 <number>)) <boolean> pure)
    (raise-simple '=:dispatch-error))

  (define-simple-proc integer-valued? (((x <object>)) <boolean> pure)
    (match-type x
      ((<integer>) #t)
      ((r <real>) (integer-float? r))
      ((rat <rational>) (rat-integer-valued? rat))
      ((cx <complex>)
       (and (= (imag-part cx) 0.0)
	    (integer-float? (real-part cx))))
      (else #f)))

  (define-simple-proc real-valued? (((x <object>)) <boolean> pure)
    (match-type x
      ((<real>) #t)
      ((<integer>) #t)
      ((<rational>) #t)
      ((cx <complex>) (= (imag-part cx) 0.0))
      (else #f)))

  (define-simple-proc rational-valued? (((x <object>)) <boolean> pure)
    (match-type x
      ((<rational>) #t)
      ((<integer>) #t)
      ;; Real and complex numbers are rational valued iff they are
      ;; integer valued.
      ((r <real>) (integer-float? r))
      ((cx <complex>)
       (and (= (imag-part cx) 0.0)
	    (integer-float? (real-part cx))))
      (else #f)))

  (define-simple-proc exact? (((nr <number>)) <boolean> pure)
    (match-type-strong nr
      ((<integer>) #t)
      ((<rational>) #t)
      ((<real>) #f)
      ((<complex>) #f)))

  (define-simple-proc inexact? (((nr <number>)) <boolean> pure)
    (match-type-strong nr
      ((<integer>) #f)
      ((<rational>) #f)
      ((<real>) #t)
      ((<complex>) #t)))

  (define real-to-rational-impl
    (prim-proc real-to-rational-impl (<real>) (:pair <integer> <integer>)
	       pure))

  (define-simple-method exact->inexact (((nr <number>)) <number> pure)
    (raise-simple 'exact->inexact:dispatch-error))

  (define-simple-method exact->inexact (((r <real-number>)) <real-number> pure)
    (raise-simple 'exact->inexact:dispatch-error))

  (add-method exact->inexact integer->real)

  (add-method exact->inexact rational->real)

  (define-simple-method exact->inexact (((r <real>)) <real> pure)
    r)

  (define-simple-method exact->inexact (((cx <complex>)) <complex> pure)
    cx)

  (define-simple-proc real->exact (((r <real>)) <rational-number> pure)
    (let ((p (real-to-rational-impl r)))
      (if (equal? (cdr p) 1)
	  (car p)
	  (rational (car p) (cdr p)))))

  (define-simple-proc complex->exact (((cx <complex>)) <rational-number> pure)
    (if (equal? (imag-part cx) 0.0)
	(real->exact (real-part cx))
	(raise-simple 'complex->exact:invalid-argument)))

  (define-simple-method inexact->exact (((nr <number>)) <rational-number> pure)
    (raise-simple 'inexact->exact:dispatch-error))

  (define-simple-method inexact->exact (((i <integer>)) <integer> pure)
    i)

  (define-simple-method inexact->exact (((rat <rational>)) <rational> pure)
    rat)

  (add-method inexact->exact real->exact)
  (add-method inexact->exact complex->exact)

  (define-simple-method + (((nr1 <number>) (nr2 <number>)) <number> pure)
    (raise-simple '+:dispatch-error))

  (define-simple-method - (((nr <number>)) <number> pure)
    (raise-simple '-:dispatch-error))

  (define-simple-method - (((nr1 <number>) (nr2 <number>)) <number> pure)
    (raise-simple '-:dispatch-error))

  (define-simple-method * (((nr1 <number>) (nr2 <number>)) <number> pure)
    (raise-simple '*:dispatch-error))

  (define-simple-method / (((nr1 <number>) (nr2 <number>)) <number> pure)
    (raise-simple '/:dispatch-error))

  (define-simple-method abs (((nr <number>)) <real-number> pure)
    (raise-simple 'abs:dispatch-error))

  (define-simple-method square (((nr <number>)) <number> pure)
    (raise-simple 'square:dispatch-error))

  (define-simple-method expt (((nr1 <number>) (nr2 <number>)) <number> pure)
    (raise-simple 'expt:dispatch-error))

  (define-simple-method expt
      (((i1 <integer>) (i2 <integer>)) <rational-number> pure)
    (if (>= i2 0)
  	(i-nonneg-expt i1 i2)
  	(rat-int-expt (integer->rational i1) i2)))
  
  (define-simple-method expt
      (((i1 <integer>) (r2 <real>)) (:union <real> <complex>) pure)
    (cond
     ((> i1 0) (r-expt (integer->real i1) r2))
     ((< i1 0) (r-complex-expt (integer->real i1) r2))
     (else (if (equal? r2 0.0) 1.0 0.0))))

  (define-simple-method expt
      (((i1 <integer>) (rat2 <rational>)) <number> pure)
    (let* ((rat-s (simplify-rational rat2)))
      (cond
       ((equal? (denominator rat-s) 1)
	(let ((i2 (numerator rat-s)))
	  (cond
	   ((equal? i2 0) 1)
	   ((equal? i2 1) i1)
	   ((> i2 1) (i-nonneg-expt i1 i2))
	   (else (rat-int-expt (integer->rational i1) i2)))))
       ;; We know here that rat2 is not 0.
       ((>= i1 0)
	(r-expt (integer->real i1) (rational->real rat-s)))
       (else
	(r-complex-expt (integer->real i1) (rational->real rat-s))))))

  (define-simple-method expt
      (((i1 <integer>) (cx2 <complex>)) <complex> pure)
    (real-complex-expt (integer->real i1) cx2))

  (define-simple-method expt
      (((r1 <real>) (i2 <integer>)) (:union <real> <integer>) pure)
    ;; Return 1 for 0.0^0, too.
    (if (not (equal? i2 0))
  	(r-int-expt r1 i2)
  	1))

  (define-simple-method expt
      (((r1 <real>) (r2 <real>)) (:union <real> <complex>) pure)
    (cond
     ((> r1 0.0) (r-expt r1 r2))
     ((< r1 0.0) (r-complex-expt r1 r2))
     ((equal? r1 0.0) (if (equal? r2 0.0) 1.0 0.0))
     (else (nan))))

  (define-simple-method expt
      (((r1 <real>) (rat2 <rational>)) (:union <integer> <real> <complex>)
       pure)
    (cond
     ((equal? rat2 0) 1)
     ((>= r1 0.0) (r-expt r1 (rational->real rat2)))
     (else (r-complex-expt r1 (rational->real rat2)))))

  (add-method expt real-complex-expt)

  (add-method expt rat-int-expt)

  (define-simple-method expt
      (((rat1 <rational>) (r2 <real>))
       (:union <integer> <real> <complex>) pure)
    (cond
     ((> rat1 0) (r-expt (rational->real rat1) r2))
     ((< rat1 0) (r-complex-expt (rational->real rat1) r2))
     (else (if (equal? r2 0.0) 1.0 0.0))))

  (define-simple-method expt
      (((rat1 <rational>) (rat2 <rational>)) <number> pure)
    (let* ((rat-s (simplify-rational rat2)))
      (cond
       ((equal? (denominator rat-s) 1)
	(rat-int-expt rat1 (numerator rat-s)))
       ;; We know here that rat2 is not 0.
       ((>= rat1 0)
	(r-expt (rational->real rat1) (rational->real rat-s)))
       (else
	(r-complex-expt (rational->real rat1) (rational->real rat-s))))))

  (define-simple-method expt
      (((rat1 <rational>) (cx2 <complex>)) <complex> pure)
    (real-complex-expt (rational->real rat1) cx2))

  (define-simple-method expt
      (((cx1 <complex>) (i2 <integer>)) (:union <complex> <integer>) pure)
    (if (not (equal? i2 0))
  	(c-int-expt cx1 i2)
  	1))

  (add-method expt complex-real-expt)


  (define-simple-method expt
      (((cx1 <complex>) (rat2 <rational>)) <complex> pure)
    (let* ((rat-s (simplify-rational rat2)))
      (cond
       ((equal? (denominator rat-s) 1)
	(c-int-expt cx1 (numerator rat-s)))
       ;; We know here that rat2 is not 0.
       (else
	(complex-real-expt cx1 (rational->real rat-s))))))

  (add-method expt c-expt)

  (define-simple-method sqrt (((nr <number>)) <number> pure)
    (raise-simple 'sqrt:dispatch-error))

  (define-simple-method sqrt (((i <integer>))
			      (:union <integer> <real> <complex>) pure)
    (if (>= i 0)
	(i-sqrt i)
	(complex 0 (r-sqrt (integer->real (i-neg i))))))

  (define-simple-method sqrt (((rat <rational>)) <number> pure)
    (if (>= rat 0)
	(rat-sqrt rat)
	;; There is no need to use rational sqrt computation in case
	;; the result is complex.
	(complex 0.0 (r-sqrt (r-neg (rational->real rat))))))

  (define-simple-method sqrt (((r <real>)) (:union <real> <complex>) pure)
    (if (>= r 0.0)
	(r-sqrt r)
	(complex 0.0 (r-sqrt (r-neg r)))))

  (add-method sqrt c-sqrt)

  (define-simple-method sin (((nr <number>)) <number> pure)
    (raise-simple 'sin:dispatch-error))

  (define-simple-method sin (((r <real-number>)) (:union <real> <integer>)
			     pure)
    (raise-simple 'sin:dispatch-error))

  (define-simple-method sin (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-sin (integer->real i))))

  (define-simple-method sin (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	0
	(r-sin (rational->real rat))))

  (add-method sin r-sin)

  (add-method sin c-sin)

  (define-simple-method cos (((nr <number>)) <number> pure)
    (raise-simple 'cos:dispatch-error))

  (define-simple-method cos (((r <real-number>)) (:union <real> <integer>)
			     pure)
    (raise-simple 'cos:dispatch-error))

  (define-simple-method cos (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	1
	(r-cos (integer->real i))))

  (define-simple-method cos (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	1
	(r-cos (rational->real rat))))

  (add-method cos r-cos)

  (add-method cos c-cos)

  (define-simple-method tan (((nr <number>)) <number> pure)
    (raise-simple 'tan:dispatch-error))

  (define-simple-method tan (((r <real-number>)) (:union <real> <integer>)
			     pure)
    (raise-simple 'tan:dispatch-error))

  (define-simple-method tan (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-tan (integer->real i))))

  (define-simple-method tan (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	0
	(r-tan (rational->real rat))))

  (add-method tan r-tan)

  (add-method tan c-tan)

  (define-simple-method asin (((nr <number>)) <number> pure)
    (raise-simple 'asin:dispatch-error))

  (define-simple-method asin (((i <integer>))
			      (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 0) 0)
     ((= i 1) (/ gl-r-pi 2))
     ((= i -1) (- (/ gl-r-pi 2)))
     (else (c-asin (integer->complex i)))))

  (define-simple-method asin (((rat <rational>))
			      (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-zero? rat) 0)
     ((and (>= rat -1) (<= rat 1)) (r-asin (rational->real rat)))
     (else (c-asin (rational->complex rat)))))

  (define-simple-method asin (((r <real>)) (:union <real> <complex>) pure)
    (if (and (<= r 1.0) (>= r -1.0))
	(r-asin r)
	(c-asin (real->complex r))))

  (add-method asin c-asin)

  (define-simple-method acos (((nr <number>)) <number> pure)
    (raise-simple 'acos:dispatch-error))

  (define-simple-method acos (((i <integer>))
			      (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 0) (/ gl-r-pi 2))
     ((= i 1) 0)
     ((= i -1) gl-r-pi)
     (else (c-acos (integer->complex i)))))

  (define-simple-method acos (((rat <rational>))
			      (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-one? rat) 0)
     ((and (>= rat -1) (<= rat 1)) (r-acos (rational->real rat)))
     (else (c-acos (rational->complex rat)))))

  (define-simple-method acos (((r <real>)) (:union <real> <complex>) pure)
    (if (and (<= r 1.0) (>= r -1.0))
	(r-acos r)
	(c-acos (real->complex r))))

  (add-method acos c-acos)

  (define-simple-method atan (((nr <number>)) <number> pure)
    (raise-simple 'atan:dispatch-error))

  (define-simple-method atan (((r <real-number>)) (:union <real> <integer>)
			      pure)
    (raise-simple 'atan:dispatch-error))

  (define-simple-method atan (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-atan (integer->real i))))

  (define-simple-method atan (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	0
	(r-atan (rational->real rat))))

  (add-method atan r-atan)

  (add-method atan c-atan)

  (define-simple-method exp (((nr <number>)) <number> pure)
    (raise-simple 'exp:dispatch-error))

  (define-simple-method exp (((r <real-number>)) (:union <real> <integer>)
			     pure)
    (raise-simple 'exp:dispatch-error))

  (define-simple-method exp (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	1
	(r-exp (integer->real i))))

  (define-simple-method exp (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	1
	(r-exp (rational->real rat))))

  (add-method exp r-exp)

  (add-method exp c-exp)

  (define-simple-method log (((nr <number>)) <number> pure)
    (raise-simple 'log:dispatch-error))

  (define-simple-method log (((i <integer>))
			     (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 0) (raise-numerical-overflow 'log))
     ((= i 1) 0)
     ((> i 0) (r-log (integer->real i)))
     (else (r-log-neg (integer->real i)))))

  (define-simple-method log (((rat <rational>))
			     (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-zero? rat) (raise-numerical-overflow 'log))
     ((rat-one? rat) 0)
     ((> rat 0) (r-log (rational->real rat)))
     (else (r-log-neg (rational->real rat)))))

  (define-simple-method log (((r <real>)) (:union <real> <complex>) pure)
    (if (>= r 0.0)
	(r-log r)
	(r-log-neg r)))

  (add-method log c-log)

  (define-simple-method log10 (((nr <number>)) <number> pure)
    (raise-simple 'log10:dispatch-error))

  (define-simple-method log10 (((i <integer>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 0) (raise-numerical-overflow 'log10))
     ((= i 1) 0)
     ((> i 0)
      (match-type-strong (i-log10-exact i)
	((<null>) (r-log10 (integer->real i)))
	((i2 <integer>) i2)))
     (else (r-log10-neg (integer->real i)))))

  (define-simple-method log10 (((rat <rational>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-zero? rat) (raise-numerical-overflow 'log10))
     ((rat-one? rat) 0)
     ((> rat 0)
      (match-type-strong (rat-log10-exact rat)
	((<null>) (r-log10 (rational->real rat)))
	((i2 <integer>) i2)))
     (else (r-log10-neg (rational->real rat)))))

  (define-simple-method log10 (((r <real>)) (:union <real> <complex>) pure)
    (if (>= r 0.0)
	(r-log10 r)
	(r-log10-neg r)))

  (add-method log10 c-log10)

  (define-simple-method sinh (((nr <number>)) <number> pure)
    (raise-simple 'sinh:dispatch-error))

  (define-simple-method sinh (((r <real-number>)) (:union <real> <integer>)
			      pure)
    (raise-simple 'sinh:dispatch-error))

  (define-simple-method sinh (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-sinh (integer->real i))))

  (define-simple-method sinh (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	0
	(r-sinh (rational->real rat))))

  (add-method sinh r-sinh)

  (add-method sinh c-sinh)

  (define-simple-method cosh (((nr <number>)) <number> pure)
    (raise-simple 'cosh:dispatch-error))

  (define-simple-method cosh (((r <real-number>)) (:union <real> <integer>)
			      pure)
    (raise-simple 'cosh:dispatch-error))

  (define-simple-method cosh (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	1
	(r-cosh (integer->real i))))

  (define-simple-method cosh (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	1
	(r-cosh (rational->real rat))))

  (add-method cosh r-cosh)

  (add-method cosh c-cosh)

  (define-simple-method tanh (((nr <number>)) <number> pure)
    (raise-simple 'tanh:dispatch-error))

  (define-simple-method tanh (((r <real-number>)) (:union <real> <integer>)
			      pure)
    (raise-simple 'tanh:dispatch-error))

  (define-simple-method tanh (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-tanh (integer->real i))))

  (define-simple-method tanh (((rat <rational>)) (:union <real> <integer>) pure)
    (if (rat-zero? rat)
	0
	(r-tanh (rational->real rat))))

  (add-method tanh r-tanh)

  (add-method tanh c-tanh)

  (define-simple-method asinh (((nr <number>)) <number> pure)
    (raise-simple 'asinh:dispatch-error))

  (define-simple-method asinh (((r <real-number>)) (:union <real> <integer>)
			       pure)
    (raise-simple 'asinh:dispatch-error))

  (define-simple-method asinh (((i <integer>)) (:union <real> <integer>) pure)
    (if (= i 0)
	0
	(r-asinh (integer->real i))))

  (define-simple-method asinh (((rat <rational>)) (:union <real> <integer>)
			       pure)
    (if (rat-zero? rat)
	0
	(r-asinh (rational->real rat))))

  (add-method asinh r-asinh)

  (add-method asinh c-asinh)

  (define-simple-method acosh (((nr <number>)) <number> pure)
    (raise-simple 'acosh:dispatch-error))

  (define-simple-method acosh (((i <integer>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 1) 0)
     ((> i 1) (r-acosh (integer->real i)))
     (else (c-acosh (integer->complex i)))))

  (define-simple-method acosh (((rat <rational>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-one? rat) 0)
     ((> rat 1) (r-acosh (rational->real rat)))
     (else (c-acosh (rational->complex rat)))))

  (define-simple-method acosh (((r <real>)) (:union <real> <complex>) pure)
    (if (>= r 1.0)
	(r-acosh r)
	(c-acosh (real->complex r))))

  (add-method acosh c-acosh)

  (define-simple-method atanh (((nr <number>)) <number> pure)
    (raise-simple 'atanh:dispatch-error))

  (define-simple-method atanh (((i <integer>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((= i 0) 0)
     ((= i 1) (inf))
     ((= i -1) (neg-inf))
     (else (c-atanh (integer->complex i)))))

  (define-simple-method atanh (((rat <rational>))
			       (:union <integer> <real> <complex>) pure)
    (cond
     ((rat-zero? rat) 0)
     ((and (<= rat 1) (>= rat -1)) (r-atanh (rational->real rat)))
     (else (c-atanh (rational->complex rat)))))

  (define-simple-method atanh (((r <real>)) (:union <real> <complex>) pure)
    (if (and (<= r 1.0) (>= r -1.0))
	(r-atanh r)
	(c-atanh (real->complex r))))

  (add-method atanh c-atanh)

  (define-simple-method atan2 (((r1 <real-number>) (r2 <real-number>))
			       (:union <real> <integer>) pure)
    (raise-simple 'atan2:dispatch-error))

  (define-simple-method atan2 (((i1 <integer>) (i2 <integer>))
			       (:union <real> <integer>) pure)
    (if (and (= i1 0) (>= i2 0))
	0
	(r-atan2 (integer->real i1) (integer->real i2))))

  (define-simple-method atan2 (((i1 <integer>) (rat2 <rational>))
			       (:union <real> <integer>) pure)
    (if (and (= i1 0) (>= rat2 0))
	0
	(r-atan2 (integer->real i1) (rational->real rat2))))

  (define-simple-method atan2 (((i1 <integer>) (r2 <real>)) <real> pure)
    (r-atan2 (integer->real i1) r2))

  (define-simple-method atan2 (((rat1 <rational>) (i2 <integer>))
			       (:union <real> <integer>) pure)
    (if (and (rat-zero? rat1) (>= i2 0))
	0
	(r-atan2 (rational->real rat1) (integer->real i2))))

  (define-simple-method atan2 (((rat1 <rational>) (rat2 <rational>))
			       (:union <real> <integer>) pure)
    (if (and (rat-zero? rat1) (>= rat2 0))
	0
	(r-atan2 (rational->real rat1) (rational->real rat2))))

  (define-simple-method atan2 (((rat1 <rational>) (r2 <real>)) <real> pure)
    (r-atan2 (rational->real rat1) r2))

  (define-simple-method atan2 (((r1 <real>) (i2 <integer>)) <real> pure)
    (r-atan2 r1 (integer->real i2)))

  (define-simple-method atan2 (((r1 <real>) (rat2 <rational>)) <real> pure)
    (r-atan2 r1 (rational->real rat2)))

  (add-method atan2 r-atan2))


