;;;; 94.stk             -- Implementation of SRFI-94
;;;;
;;;; Copyright © 2021 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 3 of the License, or
;;;; (at your option) any later version.
;;;;
;;;; This program is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI by Aubrey Jaffer, it is copyrighted as:
;;;;
;;;;;; Copyright (C) Aubrey Jaffer 2006. All Rights Reserved.
;;;;;;
;;;;;; Permission is hereby granted, free of charge, to any person
;;;;;; obtaining a copy of this software and associated documentation files
;;;;;; (the "Software"), to deal in the Software without restriction,
;;;;;; including without limitation the rights to use, copy, modify, merge,
;;;;;; publish, distribute, sublicense, and/or sell copies of the Software,
;;;;;; and to permit persons to whom the Software is furnished to do so,
;;;;;; subject to the following conditions:
;;;;;;
;;;;;; The above copyright notice and this permission notice shall be
;;;;;; included in all copies or substantial portions of the Software.
;;;;;;
;;;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;;;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;;;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;;;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 18-Jul-2020 12:43 (jpellegrini)
;;;;

(define-library srfi/94

  (import (except SCHEME
                  make-rectangular
                  make-polar
                  quotient
                  remainder
                  modulo))

  (import (srfi 60))    ;ash, integer-length


(export real-exp
        real-ln
        real-log
        real-sin
        real-cos
        real-tan
        real-asin
        real-acos
        real-atan
        ;;atan - not even defined in this implementation. And STklos already does
        ;;       what the SRFI says
        real-sqrt
        integer-sqrt
        integer-log
        integer-expt
        real-expt
        quo
        rem
        mod
        ln
        make-rectangular
        make-polar
        ;;abs - no need to change, STklos already does it as the SRFI says
        quotient
        remainder
        modulo
        )

(begin

(define scheme:make-rectangular (in-module SCHEME make-rectangular))
(define scheme:make-polar       (in-module SCHEME make-polar))
(define scheme:quotient         (in-module SCHEME quotient))
(define scheme:remainder        (in-module SCHEME remainder))
(define scheme:modulo           (in-module SCHEME modulo))


(define (type-error procedure . args)
  (apply error (cons procedure
                     (cons "bad number"
                           args))))

;@
(define (integer-expt x1 x2)
  (cond ((and (exact? x1) (integer? x1)
              (exact? x2) (integer? x2)
              (not (and (not (<= -1 x1 1)) (negative? x2))))
         (expt x1 x2))
        (else (type-error 'integer-expt x1 x2))))
;@
(define (integer-log base k)
  (define (ilog m b k)
    (cond ((< k b) k)
          (else
           (set! n (+ n m))
           (let ((q (ilog (+ m m) (* b b) (scheme:quotient k b))))
             (cond ((< q b) q)
                   (else (set! n (+ m n))
                         (scheme:quotient q b)))))))
  (define n 1)
  (define (eigt? k j) (and (exact? k) (integer? k) (> k j)))
  (cond ((not (and (eigt? base 1) (eigt? k 0)))
         (type-error 'integer-log base k))
        ((< k base) 0)
        (else (ilog 1 base (scheme:quotient k base)) n)))

;;;; http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/lisp/code/math/isqrt/isqrt.txt
;;; Akira Kurihara
;;; School of Mathematics
;;; Japan Women's University
;@
(define integer-sqrt
  (let ((table '#(0
                  1 1 1
                  2 2 2 2 2
                  3 3 3 3 3 3 3
                  4 4 4 4 4 4 4 4 4))
        (square (lambda (x) (* x x))))
    (lambda (n)
      (define (isqrt n)
        (if (> n 24)
            (let* ((len/4 (scheme:quotient (- (integer-length n) 1) 4))
                   (top (isqrt (ash n (* -2 len/4))))
                   (init (ash top len/4))
                   (q (scheme:quotient n init))
                   (iter (scheme:quotient (+ init q) 2)))
              (cond ((odd? q) iter)
                    ((< (scheme:remainder n init) (square (- iter init))) (- iter 1))
                    (else iter)))
            (vector-ref table n)))
      (if (and (exact? n) (integer? n) (not (negative? n)))
          (isqrt n)
          (type-error 'integer-sqrt n)))))

(define (must-be-exact-integer2 name proc)
  (lambda (n1 n2)
    (if (and (integer? n1) (integer? n2) (exact? n1) (exact? n2))
        (proc n1 n2)
        (type-error name n1 n2))))
;@
(define quotient  (must-be-exact-integer2 'quotient scheme:quotient))
(define remainder (must-be-exact-integer2 'remainder scheme:remainder))
(define modulo    (must-be-exact-integer2 'modulo scheme:modulo))

;;;; real-only functions
;@
(define (quo x1 x2) (truncate (/ x1 x2)))
(define (rem x1 x2) (- x1 (* x2 (quo x1 x2))))
(define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2)))))

(define (must-be-real name proc)
  (lambda (x1)
    (if (real? x1) (proc x1) (type-error name x1))))
(define (must-be-real+ name proc)
  (lambda (x1)
    (if (and (real? x1) (>= x1 0))
        (proc x1)
        (type-error name x1))))
(define (must-be-real-1+1 name proc)
  (lambda (x1)
    (if (and (real? x1) (<= -1 x1 1))
        (proc x1)
        (type-error name x1))))
;@
(define ln log)
;;(define abs       (must-be-real 'abs abs)) STklos already does this
(define real-sin  (must-be-real 'real-sin sin))
(define real-cos  (must-be-real 'real-cos cos))
(define real-tan  (must-be-real 'real-tan tan))
(define real-exp  (must-be-real 'real-exp exp))
(define real-ln   (must-be-real+ 'ln ln))
(define real-sqrt (must-be-real+ 'real-sqrt sqrt))
(define real-asin (must-be-real-1+1 'real-asin asin))
(define real-acos (must-be-real-1+1 'real-acos acos))

(define (must-be-real2 name proc)
  (lambda (x1 x2)
    (if (and (real? x1) (real? x2)) (proc x1 x2) (type-error name x1 x2))))
;@
(define make-rectangular (must-be-real2 'make-rectangular scheme:make-rectangular))
(define make-polar       (must-be-real2 'make-polar scheme:make-polar))

;@
(define real-log
  (lambda (base x)
    (if (and (real? x) (positive? x)
             (real? base) (positive? base))
        (/ (ln x) (ln base))
        (type-error 'real-log base x))))
;@
(define (real-expt x1 x2)
  (cond ((and (real? x1)
              (real? x2)
              (or (not (negative? x1)) (integer? x2)))
         (expt x1 x2))
        (else (type-error 'real-expt x1 x2))))

;@
(define real-atan
  (lambda (y . x)
    (if (and (real? y)
             (or (null? x)
                 (and (= 1 (length x))
                      (real? (car x)))))
        (apply atan y x)
        (apply type-error 'real-atan y x))))

)) ;; END OF DEFINE-LIBRARY

(provide "srfi/94")
