;; -*-theme-d-*-

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

;; The following procedures have been checked for result type safety
;; against Guile 3.0.7 source code:
;;   quotient, remainder, r-round, r-truncate, r-floor, r-ceiling,
;;   i-abs, r-abs, gcd, nan, inf, nan?, infinite?, finite?
;; The result type safety of the following procedures has been checked:
;;   integer->real, real->integer, round, truncate, floor, ceiling

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

  (add-method quotient
    (unchecked-prim-proc quotient (<integer> <integer>) <integer> pure))

  (add-method remainder
    (unchecked-prim-proc remainder (<integer> <integer>) <integer> pure))

  (add-method integer->real
    (unchecked-prim-proc integer->real (<integer>) <real> pure))

  (add-method real->integer
    (unchecked-prim-proc real->integer (<real>) <integer> pure))

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

  (add-method round
    (unchecked-prim-proc theme-round (<real>) <integer> pure))

  (add-method truncate
    (unchecked-prim-proc theme-truncate (<real>) <integer> pure))

  (add-method floor
    (unchecked-prim-proc theme-floor (<real>) <integer> pure))

  (add-method ceiling
    (unchecked-prim-proc theme-ceiling (<real>) <integer> pure))

  (add-method r-round
    (unchecked-prim-proc round (<real>) <real> pure))

  (add-method r-truncate
    (unchecked-prim-proc truncate (<real>) <real> pure))

  (add-method r-floor
    (unchecked-prim-proc floor (<real>) <real> pure))

  (add-method r-ceiling
    (unchecked-prim-proc ceiling (<real>) <real> pure))

  (add-method i-abs
    (unchecked-prim-proc abs (<integer>) <integer> (pure)))

  (add-method r-abs
    (unchecked-prim-proc abs (<real>) <real> (pure)))

  (include-virtual-methods abs i-abs)

  (include-virtual-methods abs r-abs)


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

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


  (include-virtual-methods square i-square)

  (include-virtual-methods square r-square)

  (define-simple-method 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-method 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-method 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)))))

  (add-method gcd
    (unchecked-prim-proc gcd (<integer> <integer>) <integer> pure))

  (define-simple-method factorial (((i <integer>)) <integer> pure)
    (assert (>= i 0))
    (if (equal? i 0) 1 (* i (factorial (- i 1)))))
  
  (define-simple-method 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-method 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-method i-sign (((i <integer>)) <integer> pure)
    (cond
     ((= i 0) 0)
     ((> i 0) 1)
     (else -1)))

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

  (include-virtual-methods sign i-sign)

  (include-virtual-methods sign r-sign)

  (add-method nan (unchecked-prim-proc nan () <real> pure))

  (add-method inf (unchecked-prim-proc inf () <real> pure))

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

  (add-method nan?
    (unchecked-prim-proc nan? (<real>) <boolean> (pure)))

  (add-method infinite?
    (unchecked-prim-proc inf? (<real>) <boolean> (pure)))

  (add-method finite?
    (unchecked-prim-proc finite? (<real>) <boolean> (pure)))

  (define-param-method min (%number)
		       (((nr1 %number) (nr2 %number)) %number pure)
    (if (<= nr1 nr2) nr1 nr2))

  (define-param-method max (%number)
		       (((nr1 %number) (nr2 %number)) %number pure)
    (if (>= nr1 nr2) nr1 nr2))

  (add-method even?
    (prim-proc even? (<integer>) <boolean> pure))

  (add-method odd?
    (prim-proc odd? (<integer>) <boolean> pure)))