math-r7rs/tests/sci-num-arith.scm

(import
  (scheme base)
  (scheme inexact)
  (macduffie helpful)
  (macduffie sci-num))

(define (print-test-table printer test rows cols expected)
  (for-each
   (lambda (arg-row expect-row)
     (for-each
      (lambda (arg-col expect-col)
        (printer arg-row arg-col expect-col (test arg-row arg-col expect-col)))
      cols
      expect-row))
   rows
   expected))

(define (print-test-row printer test row expected)
  (for-each
   (lambda (arg-row expected)
     (printer arg-row expected (test arg-row expected)))
   row
   expected))

(define (arithmetic-binary-result-printer arg-row arg-col expect-col success?)
  (unless success?
    (print "Test failed for: "
           arg-row
           ", "
           arg-col
           ", "
           expect-col)))

(define (arithmetic-unary-result-printer arg expect success?)
  (unless success?
    (print "Test failed for:"
           arg
           ", "
           expect)))

(define (sci-num-match? a b)
  (define real-a (sci-num->number a))
  (define real-b (sci-num->number b))
  (cond
   ((finite? real-a)
    (and (finite? real-b)
         (equal? (to-fixed real-a 13)
                 (to-fixed real-b 13))))
   ((nan? real-a)
    (nan? real-b))
   (else
    (= real-a real-b))))

(define add-arguments
  '(+inf.0 -inf.0 +nan.0 0.0 1.0 -1.0 3.148 -5.143))

(define mult-arguments add-arguments)

(define expt-arguments mult-arguments)

(define add-results
  '((+inf.0 +nan.0 +nan.0 +inf.0 +inf.0 +inf.0 +inf.0 +inf.0)
    (+nan.0 -inf.0 +nan.0 -inf.0 -inf.0 -inf.0 -inf.0 -inf.0)
    (+nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0)
    (+inf.0 -inf.0 +nan.0 0.0 1.0 -1.0 3.148 -5.143)
    (+inf.0 -inf.0 +nan.0 1.0 2.0 0.0 4.148 -4.143)
    (+inf.0 -inf.0 +nan.0 -1.0 0.0 -2.0 2.148 -6.143)
    (+inf.0 -inf.0 +nan.0 3.148 4.148 2.148 6.296 -1.995)
    (+inf.0 -inf.0 +nan.0 -5.143 -4.143 -6.143 -1.995 -10.286)))

(define mult-results
  '((+inf.0 -inf.0 +nan.0 +nan.0 +inf.0 -inf.0 +inf.0 -inf.0)
    (-inf.0 +inf.0 +nan.0 +nan.0 -inf.0 +inf.0 -inf.0 +inf.0)
    (+nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0 +nan.0)
    (+nan.0 +nan.0 +nan.0 0.0 0.0 -0.0 0.0 -0.0)
    (+inf.0 -inf.0 +nan.0 0.0 1.0 -1.0 3.148 -5.143)
    (-inf.0 +inf.0 +nan.0 0.0 -1.0 1.0 -3.148 5.143)
    (+inf.0 -inf.0 +nan.0 0.0 3.148 -3.148 9.909904 -16.190164)
    (-inf.0 +inf.0 +nan.0 0.0 -5.143 5.143 -16.190164 26.450449)))

(define expt-results
  '((+inf.0 0.0 +nan.0 1.0 +inf.0 0.0 +inf.0 0.0)
    (+nan.0 +nan.0 +nan.0 1.0 -inf.0 -0.0 +nan.0 -0.0)
    (+nan.0 +nan.0 +nan.0 1.0 +nan.0 +nan.0 +nan.0 +nan.0)
    (0.0 +inf.0 +nan.0 1.0 0.0 +inf.0 0.0 +inf.0)
    (1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0)
    (+nan.0 +nan.0 +nan.0 1.0 -1.0 -1.0 +nan.0 +nan.0)
    (+inf.0 0.0 +nan.0 1.0 3.148 0.3176620076238882 36.96692361914167 0.0027454112948776116)
    (+nan.0 +nan.0 +nan.0 1.0 -5.143 -0.19443904335990667 +nan.0 +nan.0)))

(define sqrt-arguments mult-arguments)

(define sqrt-results '(+inf.0 +nan.0 +nan.0 0.0 1 +nan.0))

(print "Testing sci+")
(print "--------------------")

(print-test-table arithmetic-binary-result-printer
                  (lambda (a b c)
                    (sci-num-match? (sci+ a b) c))
                  add-arguments
                  add-arguments
                  add-results)

(print "Testing sci*")
(print "--------------------")

(print-test-table arithmetic-binary-result-printer
                  (lambda (a b c)
                    (sci-num-match? (sci* a b) c))
                  mult-arguments
                  mult-arguments
                  mult-results)

(print "Testing sci-expt")
(print "--------------------")

(print-test-table arithmetic-binary-result-printer
                  (lambda (a b c)
                    (sci-num-match? (sci-expt a b) c))
                  expt-arguments
                  expt-arguments
                  expt-results)

(print "Testing sci-sqrt")
(print "--------------------")


(print-test-row arithmetic-unary-result-printer
                (lambda (a b)
                  (sci-num-match? (sci-sqrt a) b))
                sqrt-arguments
                sqrt-results)