guile-ploy/ploy/test.scm

; Functions for testers.
; (c) Daniel Llorens - 2012-2013

; This library 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.

(define-module (ploy test))
(import (ploy assert) (srfi srfi-1))

(re-export assert assert-fail)

(define (relative-error a b)
  (cond
    ((= a 0) (magnitude b))
    ((= b 0) (magnitude a))
    (else (/ (magnitude (- a b)) (+ (magnitude a) (magnitude b)) 1/2))))

(define (absolute-error a b)
  (magnitude (- a b)))

(define (T . args)
  (assert (cond ((every array? args) (apply array-equal? args))
                ((every number? args) (apply = args))
                (else (apply equal? args)))
    "T failed"))

(define (T-msg msg . args)
  (assert (cond ((every array? args) (apply array-equal? args))
                ((every number? args) (apply = args))
                (else (apply equal? args)))
    msg))

(export relative-error absolute-error T T-msg)

(define* (compare-arrays a b #:key (relative-to 1))
  (and (equal? (array-dimensions a) (array-dimensions b))
       (let* ((aerr (let ((err 0))
                     (array-for-each
                       (lambda (a b) (set! err (max err (absolute-error a b))))
                       a b)
                     err)))
         (if (= relative-to 1.)
           aerr
           (values (/ aerr relative-to) aerr)))))

(define (T-eps eps . args)
  (let ((e (cond ((every array? args)
                  (fold (lambda (a c) (max c (compare-arrays (car args) a)))
                        0. (cdr args)))
                 ((every number? args)
                  (fold (lambda (a c) (max c (absolute-error (car args) a)))
                        0 (cdr args)))
                 (else (error "bad arguments")))))
    (assert (>= eps e) "failed T-eps with eps, error" e eps)
    e))

(define (T-eps-msg msg eps . args)
  (catch #t (lambda () (apply T-eps eps args))
         (lambda x (apply throw 'precision-error msg x))))

(export compare-arrays T-eps T-eps-msg)

(define-syntax repeat
  (syntax-rules ()
    ((_ n e0 ...) (do ((i 0 (+ i 1))) ((= i n)) e0 ...))))

(export repeat)