;; -*-theme-d-*-

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

(define-body (tests numerical-test-env)

  (import (standard-library console-io))

  (define-simple-proc approx-equal?
      (((nr1 <number>) (nr2 <number>)) <boolean> pure)
    (< (abs (- nr1 nr2)) 1e-12))

  (define-simple-method my-equal?
      (((nr1 <number>) (nr2 <number>)) <boolean> pure)
    #f)

  (define-simple-method my-equal?
      (((i1 <integer>) (i2 <integer>)) <boolean> pure)
    (equal? i1 i2))

  (define-simple-method my-equal?
      (((rat1 <rational>) (rat2 <rational>)) <boolean> pure)
    (equal? rat1 rat2))

  (define-simple-method my-equal?
      (((r1 <real>) (r2 <real>)) <boolean> pure)
    (cond
     ((or (nan? r1) (nan? r2))
      (and (nan? r1) (nan? r2)))      
     ((or (infinite? r1) (infinite? r2))
      (equal? r1 r2))
     (else
      (approx-equal? r1 r2))))

  (define-simple-method my-equal?
      (((cx1 <complex>) (cx2 <complex>)) <boolean> pure)
    (approx-equal? cx1 cx2))

  (define-simple-proc do-report-test
      (((x-expr <object>) (nr-result <number>) (nr-correct <number>))
       <none> nonpure)
    (console-write x-expr)
    (console-display " = ")
    (console-write nr-result)
    (console-display "  ")
    (if (my-equal? nr-result nr-correct)
	(console-display "OK")
	(console-display "FAIL"))
    (console-newline))

  (define-simple-proc do-report-boolean-test
      (((x-expr <object>) (b-result <boolean>) (b-correct <boolean>))
       <none> nonpure)
    (console-write x-expr)
    (console-display " = ")
    (console-write b-result)
    (console-display "  ")
    (if (equal? b-result b-correct)
	(console-display "OK")
	(console-display "FAIL"))
    (console-newline))

  (define-simple-proc do-report-result (((x-expr <object>) (x-result <object>))
					<none> nonpure)
    (console-write x-expr)
    (console-display " = ")
    (console-write x-result)
    (console-newline)))

