;; -*-theme-d-*-

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


(define-body (standard-library real-math)

  (import (standard-library basic-math))
  
  (define-simple-proc rational->real (((rat <rational>)) <real> pure)
    (/ (integer->real (numerator rat)) (denominator rat)))

  (define-simple-proc real-rational= (((r <real>) (rat <rational>))
				       <boolean> pure)
    (real= r (rational->real rat)))

  (define-simple-proc rational-real= (((rat <rational>) (r <real>))
				       <boolean> pure)
    (real= (rational->real rat) r))

  (define-simple-proc real-rational< (((r <real>) (rat <rational>))
				       <boolean> pure)
    (real< r (rational->real rat)))

  (define-simple-proc rational-real< (((rat <rational>) (r <real>))
				       <boolean> pure)
    (real< (rational->real rat) r))

  (define-simple-proc real-rational<= (((r <real>) (rat <rational>))
				       <boolean> pure)
    (real<= r (rational->real rat)))

  (define-simple-proc rational-real<= (((rat <rational>) (r <real>))
				       <boolean> pure)
    (real<= (rational->real rat) r))

  (define-simple-proc real-rational> (((r <real>) (rat <rational>))
				       <boolean> pure)
    (real> r (rational->real rat)))

  (define-simple-proc rational-real> (((rat <rational>) (r <real>))
				       <boolean> pure)
    (real> (rational->real rat) r))

  (define-simple-proc real-rational>= (((r <real>) (rat <rational>))
				       <boolean> pure)
    (real>= r (rational->real rat)))

  (define-simple-proc rational-real>= (((rat <rational>) (r <real>))
				       <boolean> pure)
    (real>= (rational->real rat) r))

  (define-simple-proc real-rational+ (((r <real>) (rat <rational>))
				       <real> pure)
    (real+ r (rational->real rat)))

  (define-simple-proc rational-real+ (((rat <rational>) (r <real>))
				       <real> pure)
    (real+ (rational->real rat) r))

  (define-simple-proc real-rational- (((r <real>) (rat <rational>))
				       <real> pure)
    (real- r (rational->real rat)))

  (define-simple-proc rational-real- (((rat <rational>) (r <real>))
				       <real> pure)
    (real- (rational->real rat) r))

  (define-simple-proc real-rational* (((r <real>) (rat <rational>))
				       <real> pure)
    (real* r (rational->real rat)))

  (define-simple-proc rational-real* (((rat <rational>) (r <real>))
				       <real> pure)
    (real* (rational->real rat) r))

  (define-simple-proc real-rational/ (((r <real>) (rat <rational>))
				       <real> pure)
    ;; guile-2.2 returns +-inf if the second argument is rational zero
    ;; in this case.
    ;; guile-2.0 raises exception numerical-overflow.
    ;; We follow the former convention.
    (real/ r (rational->real rat)))

  (define-simple-proc rational-real/ (((rat <rational>) (r <real>))
				       <real> pure)
    (real/ (rational->real rat) r))

  (add-method = real-rational=)
  (add-method = rational-real=)

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

  (add-method < real-rational<)
  (add-method < rational-real<)

  (define-simple-method <= (((r1 <real-number>) (r2 <real-number>)) <boolean>
			    pure)
    (raise-simple '<=:dispatch-error))

  (add-method <= real-rational<=)
  (add-method <= rational-real<=)

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

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

  (define-simple-method >= (((r1 <real-number>) (r2 <real-number>)) <boolean>
			    pure)
    (raise-simple '>=:dispatch-error))

  (add-method >= real-rational>=)
  (add-method >= rational-real>=)

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

  (add-method + real-rational+)
  (add-method + rational-real+)

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

  (add-method - real-rational-)
  (add-method - rational-real-)

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

  (add-method * real-rational*)
  (add-method * rational-real*)

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

  (add-method / real-rational/)
  (add-method / rational-real/)

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

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

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

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

  (define r-sqrt
    (unchecked-prim-proc r-sqrt (<real>) <real> (pure)))

  (define r-expt
    (unchecked-prim-proc r-expt (<real> <real>) <real> (pure)))

  (define r-sin
    (unchecked-prim-proc r-sin (<real>) <real> (pure)))

  (define r-cos
    (unchecked-prim-proc r-cos (<real>) <real> (pure)))

  (define r-tan
    (unchecked-prim-proc r-tan (<real>) <real> (pure)))

  (define r-asin
    (unchecked-prim-proc r-asin (<real>) <real> (pure)))

  (define r-acos
    (unchecked-prim-proc r-acos (<real>) <real> (pure)))

  (define r-atan
    (unchecked-prim-proc r-atan (<real>) <real> (pure)))

  (define r-atan2
    (unchecked-prim-proc r-atan2 (<real> <real>) <real> (pure)))

  (define r-exp
    (unchecked-prim-proc r-exp (<real>) <real> (pure)))

  (define r-log
    (unchecked-prim-proc r-log (<real>) <real> (pure)))

  (define r-log10
    (unchecked-prim-proc r-log10 (<real>) <real> (pure)))

  (define r-sinh
    (unchecked-prim-proc r-sinh (<real>) <real> (pure)))

  (define r-cosh
    (unchecked-prim-proc r-cosh (<real>) <real> (pure)))

  (define r-tanh
    (unchecked-prim-proc r-tanh (<real>) <real> (pure)))

  (define r-asinh
    (unchecked-prim-proc r-asinh (<real>) <real> (pure)))

  (define r-acosh
    (unchecked-prim-proc r-acosh (<real>) <real> (pure)))

  (define r-atanh
    (unchecked-prim-proc r-atanh (<real>) <real> (pure)))

  (define-simple-proc i-sqrt (((i <integer>)) (:union <real> <integer>) pure)
    (let ((r-result (r-sqrt (integer->real i))))
      (if (integer-float? r-result) (real->integer r-result) r-result)))

  (define-simple-proc rat-sqrt (((rat <rational>))
				(:union <real> <rational> <integer>) pure)
    (let ((r-numer (r-sqrt (integer->real (numerator rat))))
	  (r-denom (r-sqrt (integer->real (denominator rat)))))
      (if (and (integer-float? r-numer) (integer-float? r-denom))
	  (let ((i-numer (real->integer r-numer))
		(i-denom (real->integer r-denom)))
	    (if (equal? (remainder i-numer i-denom) 0)
		(quotient i-numer i-denom)
		(rational i-numer i-denom)))
	  (/ r-numer r-denom))))

  (define _string->real-number
    (prim-proc theme-string->real-number (<string>)
	       (:union <real> <integer> (:pair <integer> <integer>))
	       pure))

  (define-simple-proc string->real-number (((str <string>)) <real-number> pure)
    (match-type-strong (_string->real-number str)
      ((r <real>) r)
      ((i <integer>) i)
      ((p (:pair <integer> <integer>))
       (rational (car p) (cdr p))))))
