(require-extension numbers)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SRFI-64 subset + test-approx=

(define *pass* 0)
(define *fail* 0)
(define *start* 0)
(define *epsilon* 0.001)

(define (run-test name thunk expect eq pass-msg fail-msg)
  (let ((result (thunk)))
    (cond
      ((eq expect result)
       (set! *pass* (+ *pass* 1))
       (format-result pass-msg name expect result))
      (else
       (set! *fail* (+ *fail* 1))
       (format-result fail-msg name expect result)))))

(define (format-result ls name expect result)
  (let lp ((ls ls))
    (cond
      ((null? ls) (newline))
      ((eq? (car ls) 'expect) (display expect) (lp (cdr ls)))
      ((eq? (car ls) 'result) (display result) (lp (cdr ls)))
      ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
      (else (display (car ls)) (lp (cdr ls))))))

(define (test-begin . o)
  (set! *pass* 0)
  (set! *fail* 0)
  (set! *start* (current-milliseconds)))

(define (format-float n prec)
  (let* ((str (number->string n))
         (len (string-length str)))
    (let lp ((i (- len 1)))
      (cond
        ((negative? i)
         (string-append str "." (make-string prec #\0)))
        ((eqv? #\. (string-ref str i))
         (let ((diff (+ 1 (- prec (- len i)))))
           (cond
             ((positive? diff)
              (string-append str (make-string diff #\0)))
             ((negative? diff)
              (substring str 0 (+ i prec 1)))
             (else
              str))))
        (else
         (lp (- i 1)))))))

(define (format-percent num denom)
  (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
    (format-float (* 100 x) 2)))

(define (test-end . o)
  (let ((end (current-milliseconds))
        (total (+ *pass* *fail*)))
    (printf "  ~A tests completed in ~A seconds\n"
            total (format-float (exact->inexact (/ (- end *start*) 1000)) 3))
    (printf "  ~A (~A%) tests passed\n"
            *pass* (format-percent *pass* total))
    (printf "  ~A (~A%) tests failed\n"
            *fail* (format-percent *fail* total))))

(define (run-assert name thunk)
  (run-test name thunk #t (lambda (expect result) result)
            '("[PASS]" name) '("[FAIL]" name)))

(define-syntax test-assert
  (syntax-rules ()
    ((_ x opt)
     (run-assert x (lambda () opt)))
    ((_ x)
     (run-assert 'x (lambda () x)))))

(define (run-equal name thunk expect eq)
  (run-test name thunk expect eq
            '("[PASS]" name)
            '("[FAIL]" name ": expected " expect " but got " result)))

(define-syntax test-equal
  (syntax-rules ()
    ((_ x y opt)
     (run-equal x (lambda () y) opt equal?))
    ((_ x y)
     (run-equal 'x (lambda () x) y equal?))))

(define-syntax test=
  (syntax-rules ()
    ((_ x y opt)
     (run-equal x (lambda () y) opt =))
    ((_ x y)
     (run-equal 'x (lambda () x) y =))))

(define (real-approx= expected result)
  (cond
    ((zero? result)
     (< (abs expected) *epsilon*))
    ((zero? expected)
     (< (abs result) *epsilon*))
    (else
     (< (min (abs (- 1 (/ expected result)))
             (abs (- 1 (/ result expected))))
        *epsilon*))))

(define (approx= expected result)
  (and (real-approx= (real-part expected) (real-part result))
       (real-approx= (imag-part expected) (imag-part result))))

(define-syntax test-approx=
  (syntax-rules ()
    ((_ x y opt)
     (run-equal x (lambda () y) opt approx=))
    ((_ x y)
     (run-equal 'x (lambda () x) y approx=))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run tests

(test-begin "numbers")

;; basic cases, fixnum base
(test= (expt 0 0) 1)
(test= (expt 2 0) 1)
(test= (expt 2 1) 2)
(test= (expt 2 2) 4)
(test= (expt 3 2) 9)
(test= (expt 3 2.0) 9)
(test-approx= (expt 3 2.1) 10.0451)
(test-approx= (expt 3 0.1) 1.1161)
(test-approx= (expt 3 -1) 1/3)
(test-approx= (expt 3 -2) 1/9)
(test-approx= (expt 3 -2.1) 0.09955)

;; basic cases, flonum base
(test= (expt 0.0 0) 1)
(test= (expt 3.14 0) 1)
(test= (expt 3.14 1) 3.14)
(test= (expt 3.14 2) 9.8596)
(test= (expt 3.14 2.0) 9.8596)
(test-approx= (expt 3.14 2.1) 11.0548)
(test-approx= (expt 3.14 0.1) 1.1212)
(test-approx= (expt 3.14 -1) 0.31847)
(test-approx= (expt 3.14 -2) 0.10142)
(test-approx= (expt 3.14 -2.1) 0.090458)

;; check overflows into bignums
(test= (expt 2 30) (string->number "1073741824"))
(test= (expt 2 31) (string->number "2147483648"))
(test= (expt 2 32) (string->number "4294967296"))
(test= (expt 2 62) (string->number "4611686018427387904"))
(test= (expt 2 63) (string->number "9223372036854775808"))
(test= (expt 2 64) (string->number "18446744073709551616"))

;; bug reported on the chicken list
(define (one-followed-by-n-zeros n)
  (string->number (string-append "1" (make-string n #\0))))

(test= (expt 10 100) (one-followed-by-n-zeros 100))

;; bignum base
(test= (expt (one-followed-by-n-zeros 100) 0) 1)
(test= (expt (one-followed-by-n-zeros 100) 1) (one-followed-by-n-zeros 100))
(test= (expt (one-followed-by-n-zeros 100) 2) (one-followed-by-n-zeros 200))
(test-approx= (expt (one-followed-by-n-zeros 100) 0.1) 10000000000)

;; e^(pi*i) = -1
(test-approx= (expt (exp 1) (* (acos -1) (sqrt -1))) -1)

;; rational rounding

(test= (round (/ 9 10)) 1)
(test= (round (/ 6 10)) 1)
(test= (round (/ 5 10)) 0)
(test= (round (/ 1 10)) 0)
(test= (round (/ 0 10)) 0)
(test= (round (/ -1 10)) 0)
(test= (round (/ -5 10)) 0)
(test= (round (/ -6 10)) -1)
(test= (round (/ -9 10)) -1)
(test= (round (/ (expt 10 10000) (+ (expt 10 10000) 1))) 1)
(test= (round (/ (+ 1 (expt 10 10000)) (expt 10 100))) (expt 10 9900))

(test-end "numbers")