;; -*-theme-d-*-

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

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

  (import (standard-library bitwise-arithmetic))

  ;; The result types of primitive numerical procedures are checked because
  ;; of the way numerical types are implemented in Scheme.

  (define quotient
    (prim-proc quotient (<integer> <integer>) <integer> pure))

  (define remainder
    (prim-proc remainder (<integer> <integer>) <integer> pure))

  (define integer->real
    (prim-proc integer->real (<integer>) <real> pure))

  (define real->integer
    (prim-proc real->integer (<real>) <integer> pure))

  (define integer-float?
    (unchecked-prim-proc integer-valued? (<real>) <boolean> pure))

  (define round
    (prim-proc theme-round (<real>) <integer> pure))

  (define truncate
    (prim-proc theme-truncate (<real>) <integer> pure))

  (define floor
    (prim-proc theme-floor (<real>) <integer> pure))

  (define ceiling
    (prim-proc theme-ceiling (<real>) <integer> pure))

  (define r-round
    (prim-proc round (<real>) <real> pure))

  (define r-truncate
    (prim-proc truncate (<real>) <real> pure))

  (define r-floor
    (prim-proc floor (<real>) <real> pure))

  (define r-ceiling
    (prim-proc ceiling (<real>) <real> pure))

  (define i-abs
    (prim-proc abs (<integer>) <integer> (pure)))

  (define r-abs
    (prim-proc abs (<real>) <real> (pure)))

  (add-method abs i-abs)

  (add-method abs r-abs)


  (define-simple-proc i-square (((n <integer>)) <integer> (pure))
    (* n n))

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


  (add-method square i-square)

  (add-method square r-square)

  (define-simple-proc i-nonneg-expt (((i-base <integer>) (i-exponent <integer>))
				     <integer> pure)
    (assert (>= i-exponent 0))
    (let-mutable ((i-cur-exponent <integer> i-exponent)
		  (i-cur-base <integer> i-base)
		  (i-sum <integer> 1))
      (until ((or (equal? i-cur-exponent 0) (equal? i-cur-exponent 1)))
	(if (not (equal? (bitwise-and i-cur-exponent 1) 0))
	    (set! i-sum (* i-sum i-cur-base)))
	(set! i-cur-base (square i-cur-base))
	(set! i-cur-exponent (ash i-cur-exponent -1)))
      (cond
       ((= i-cur-exponent 0) i-sum)
       ((= i-cur-exponent 1) (* i-sum i-cur-base))
       (else (raise-simple 'i-expt:internal-error)))))

  (define-simple-proc r-nonneg-int-expt
      (((r-base <real>) (i-exponent <integer>)) <real> pure)
    (assert (>= i-exponent 0))
    (let-mutable ((i-cur-exponent <integer> i-exponent)
		  (r-cur-base <real> r-base)
		  (r-sum <real> 1.0))
      (until ((or (equal? i-cur-exponent 0) (equal? i-cur-exponent 1)))
	(if (not (equal? (bitwise-and i-cur-exponent 1) 0))
	    (set! r-sum (* r-sum r-cur-base)))
	(set! r-cur-base (square r-cur-base))
	(set! i-cur-exponent (ash i-cur-exponent -1)))
      (cond
       ((= i-cur-exponent 0) r-sum)
       ((= i-cur-exponent 1) (* r-sum r-cur-base))
       (else (raise-simple 'r-nonneg-int-expt:internal-error)))))

  (define-simple-proc r-int-expt (((r-base <real>) (i-expt <integer>))
				  <real> pure)
    (if (>= i-expt 0)
	(r-nonneg-int-expt r-base i-expt)
	(/ 1.0 (r-nonneg-int-expt r-base (i-neg i-expt)))))

  (define gcd
    (prim-proc gcd (<integer> <integer>) <integer> pure))

  (define-simple-proc factorial (((i <integer>)) <integer> pure)
    (assert (>= i 0))
    (if (equal? i 0) 1 (* i (factorial (- i 1)))))
  
  (define-simple-proc i-log10-exact (((i <integer>)) (:maybe <integer>) pure)
    (assert (>= i 1))
    (let-mutable ((stop? <boolean> #f)
		  (i-sum <integer> 0))
      (do ((i-cur <integer> i (quotient i-cur 10))) ((or stop? (<= i-cur 1)))
	(if (not (equal? (remainder i-cur 10) 0))
	    (set! stop? #t)
	    (set! i-sum (+ i-sum 1))))
      (if (not stop?) i-sum null)))

  (define-simple-proc i-log2-exact (((i <integer>)) (:maybe <integer>) pure)
    (assert (>= i 1))
    (let-mutable ((stop? <boolean> #f)
		  (i-sum <integer> 0))
      (do ((i-cur <integer> i (ash i-cur -1))) ((or stop? (<= i-cur 1)))
	(if (not (equal? (bitwise-and i-cur 1) 0))
	    (set! stop? #t)
	    (set! i-sum (+ i-sum 1))))
      (if (not stop?) i-sum null)))

  (define-simple-proc i-sign (((i <integer>)) <integer> pure)
    (cond
     ((= i 0) 0)
     ((> i 0) 1)
     (else -1)))

  (define-simple-proc r-sign (((r <real>)) <integer> pure)
    (cond
     ((> r 0.0) 1)
     ((< r 0.0) -1)
     ((= r 0.0) 0)
     (else 0)))

  (add-method sign i-sign)

  (add-method sign r-sign)

  (define nan (prim-proc nan () <real> pure))

  (define inf (prim-proc inf () <real> pure))

  (define-simple-proc neg-inf (() <real> pure)
    (- (inf)))

  (define nan?
    (prim-proc nan? (<real>) <boolean> (pure)))

  (define infinite?
    (prim-proc inf? (<real>) <boolean> (pure)))

  (define finite?
    (prim-proc finite? (<real>) <boolean> (pure))))
