
;; Copyright (C) 2018-2019 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.


(define-module (theme-d runtime theme-d-support)
  #:export (is-real?
	    is-integer?
	    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))


(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 (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))))
