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

;; Alternative support for primitives written in Scheme.

#lang racket

(provide is-real?
	 is-integer?
	 nan
	 inf
	 log10
	 r-sqrt
	 r-expt
	 r-sin
	 r-cos
	 r-tan
	 r-asin
	 r-acos
	 r-atan
	 r-atan2
	 r-exp
	 r-log
	 r-log10
	 r-sinh
	 r-cosh
	 r-tanh
	 r-asinh
	 r-acosh
	 r-atanh
	 r-round
	 r-truncate
	 r-floor
	 r-ceiling)


(require math/base)


(define (is-real? x)
  (and (real? x)
       ;; (not (and (integer? x) (exact? x)))))
       ;; Integer and rational numbers are not accepted as real numbers
       ;; in Theme-D.
       (not (exact? x))))


(define (is-integer? x)
  (and (integer? x) (exact? x)))


(define (nan) +nan.0)


(define (inf) +inf.0)


(define (log10 z) (/ (log z) (log 10)))


(define (r-sqrt r)
  (if (< r 0.0)
      (nan)
      (let ((r-result
	     (exact->inexact (sqrt r))))
	(if (is-real? r-result)
	    r-result
	    (raise 'r-sqrt:internal-type-error)))))


(define (r-expt r1 r2)
  (cond
   ((< r1 0.0) (nan))
   ((= r1 0.0) 1.0)
   (else
    (let ((r-result
	   (exact->inexact (expt r1 r2))))
      (if (is-real? r-result)
	  r-result
	  (raise 'r-expt:internal-type-error))))))


(define (r-sin r)
  (let ((r-result (exact->inexact (sin r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-sin:internal-type-error))))


(define (r-cos r)
  (let ((r-result (exact->inexact (cos r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-cos:internal-type-error))))


(define (r-tan r)
  (let ((r-result (exact->inexact (tan r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-tan:internal-type-error))))


(define (r-asin r)
  (let ((x-result
	 (exact->inexact (asin r))))
    (cond
     ((is-real? x-result) x-result)
     ;; Scheme integers are rational numbers, too.
     ((rational? x-result) (raise 'r-asin:internal-type-error))
     (else (nan)))))


(define (r-acos r)
  (let ((x-result
	 (exact->inexact (acos r))))
    (cond
     ((is-real? x-result) x-result)
     ;; Scheme integers are rational numbers, too.
     ((rational? x-result) (raise 'r-acos:internal-type-error))
     (else (nan)))))


(define (r-atan r)
  ;; atan(x) is real for all real x
  (let ((r-result (exact->inexact (atan r))))
    (if (is-real? r-result) r-result (raise 'r-atan:internal-type-error))))


(define (r-atan2 y x)
  (let ((r-result (exact->inexact (atan y x))))
    (if (is-real? r-result) r-result (raise 'r-atan2:internal-type-error))))


(define (r-exp r)
  (let ((r-result (exact->inexact (exp r))))
    (if (is-real? r-result) r-result (raise 'r-exp:internal-type-error))))


(define (r-log r)
  (cond
   ((> r 0.0)
    (let ((r-result (exact->inexact (log r))))
      (if (is-real? r-result) r-result (raise 'r-log:internal-type-error))))
   ((= r 0.0) (- (inf)))
   (else (nan))))


(define (r-log10 r)
  (cond
   ((> r 0.0)
    (let ((r-result (exact->inexact (log10 r))))
      (if (is-real? r-result) r-result (raise 'r-log:internal-type-error))))
   ((= r 0.0) (- (inf)))
   (else (nan))))


(define (r-sinh r)
  (let ((r-result (exact->inexact (sinh r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-sinh:internal-type-error))))


(define (r-cosh r)
  (let ((r-result (exact->inexact (cosh r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-cosh:internal-type-error))))


(define (r-tanh r)
  (let ((r-result (exact->inexact (tanh r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-tanh:internal-type-error))))


(define (r-asinh r)
  ;; asinh(x) is real for all real x (?)
  (let ((r-result (exact->inexact (asinh r))))
    (if (is-real? r-result)
	r-result
	(raise 'r-asinh:internal-type-error))))


(define (r-acosh r)
  ;; acosh(x) is real for all x >= 1
  (let ((x-result (exact->inexact (acosh r))))
    (cond
     ((is-real? x-result) x-result)
     ((rational? x-result) (raise 'r-acosh:internal-type-error))
     (else (nan)))))


(define (r-atanh r)
  ;; atanh(x) is real for all real -1 <= x <= 1
  (if (and (>= r -1.0) (<= r 1.0))
      (let ((r-result (exact->inexact (atanh r))))
	(if (is-real? r-result)
	    r-result
	    (raise 'r-atanh:internal-type-error)))
      (nan)))


(define (r-round r)
  (let ((r-result (round r)))
    (if (is-real? r-result)
	r-result
	(raise 'r-round:internal-type-error))))


(define (r-truncate r)
  (let ((r-result (truncate r)))
    (if (is-real? r-result)
	r-result
	(raise 'r-truncate:internal-type-error))))


(define (r-floor r)
  (let ((r-result (floor r)))
    (if (is-real? r-result)
	r-result
	(raise 'r-floor:internal-type-error))))


(define (r-ceiling r)
  (let ((r-result (ceiling r)))
    (if (is-real? r-result)
	r-result
	(raise 'r-ceiling:internal-type-error))))
