172 lines
6.5 KiB
Scheme
172 lines
6.5 KiB
Scheme
;;;
|
|
;;; Name: imath-test.scm
|
|
;;; Purpose: Code to generate random rational number test cases.
|
|
;;; Notes: Written for DrRacket (nee PLT Scheme)
|
|
;;;
|
|
(require (lib "27.ss" "srfi"))
|
|
|
|
;; Generate a random natural number with the specified number of digits.
|
|
(define (random-big-natural digits)
|
|
(let loop ((d "") (digits digits))
|
|
(if (zero? digits)
|
|
(string->number d 10)
|
|
(let ((rnd (random 10)))
|
|
(loop (string-append d (list->string
|
|
(list
|
|
(integer->char
|
|
(+ rnd
|
|
(char->integer #\0))))))
|
|
(- digits 1))))))
|
|
|
|
;; Generate a random integer with the specified number of digits and
|
|
;; probability (0..1) of being negative.
|
|
(define (random-big-integer digits pneg)
|
|
(let ((base (random-big-natural digits)))
|
|
(if (< (random-real) pneg)
|
|
(* base -1)
|
|
base)))
|
|
|
|
;; Generate a random rational number with the specified number of numerator and
|
|
;; denominator digits, and probability pneg (0..1) of being negative.
|
|
(define (random-big-rational n-digits d-digits pneg)
|
|
(let ((num (random-big-natural n-digits))
|
|
(den (random-big-natural d-digits)))
|
|
(if (zero? den)
|
|
(random-big-rational n-digits d-digits pneg)
|
|
(if (< (random-real) pneg)
|
|
(- (/ num den))
|
|
(/ num den)))))
|
|
|
|
;; Create a rational generator with a fixed negative probability.
|
|
;; Always generates rationals.
|
|
(define (make-rat-generator prob-neg)
|
|
(lambda (n-digits d-digits num)
|
|
(random-big-rational n-digits d-digits prob-neg)))
|
|
|
|
;; Create a rational generator with a fixed negative probability. With
|
|
;; probability prob-backref, generates a back-reference to an earlier input
|
|
;; value, rather than a new value. This is used to make sure argument
|
|
;; overlapping works the way it should.
|
|
(define (make-backref-generator prob-neg prob-backref)
|
|
(lambda (n-digits d-digits num)
|
|
(if (and (> num 1)
|
|
(< (random-real) prob-backref))
|
|
(let ((ref (+ (random (- num 1)) 1)))
|
|
(string-append "=" (number->string ref)))
|
|
(random-big-rational n-digits d-digits prob-neg))))
|
|
|
|
;; Just like make-backref-generator, except the second argument is always an
|
|
;; integer, and the backreference can only be to the first argument.
|
|
(define (make-backref-generator-2 prob-neg prob-backref)
|
|
(lambda (n-digits d-digits num)
|
|
(case num
|
|
((1) (random-big-rational n-digits d-digits prob-neg))
|
|
((2) (random-big-integer n-digits prob-neg))
|
|
(else
|
|
(if (< (random-real) prob-backref)
|
|
"=1"
|
|
(random-big-rational n-digits d-digits prob-neg))))))
|
|
|
|
(define (make-output-test-generator prob-neg max-dig)
|
|
(lambda (n-digits d-digits num)
|
|
(cond ((= num 1)
|
|
(random-big-rational n-digits d-digits prob-neg))
|
|
((= num 2)
|
|
(let loop ((radishes '(10 16 8 4 2)))
|
|
(cond ((null? radishes)
|
|
(+ (random 34) 2))
|
|
((< (random-real) 0.3)
|
|
(car radishes))
|
|
(else
|
|
(loop (cdr radishes))))))
|
|
(else
|
|
(random max-dig))
|
|
)))
|
|
|
|
;; Given a test name, an argument generator, and an operation to compute the
|
|
;; desired solution, return a function that generates a random test case for a
|
|
;; given number of digits of precision in the numerator and denominator.
|
|
(define (make-test-case-generator name arg-gen op)
|
|
(lambda (n-digits d-digits)
|
|
(let ((args (list (arg-gen n-digits d-digits 1)
|
|
(arg-gen n-digits d-digits 2)
|
|
(arg-gen n-digits d-digits 3))))
|
|
(let* ((arg1 (car args))
|
|
(arg2 (if (equal? (cadr args) "=1")
|
|
arg1 (cadr args)))
|
|
(soln (if (and (eq? op /)
|
|
(zero? arg2))
|
|
"$MP_UNDEF"
|
|
(op arg1 arg2))))
|
|
(list
|
|
name
|
|
args
|
|
(list soln))))))
|
|
|
|
;; Glue strings together with the specified joiner.
|
|
(define (join-strings joiner lst)
|
|
(cond ((null? lst) "")
|
|
((null? (cdr lst)) (car lst))
|
|
(else
|
|
(string-append (car lst) joiner
|
|
(join-strings joiner (cdr lst))))))
|
|
|
|
;; Convert a test case generated by a test case generator function into a
|
|
;; writable string, in the format used by imtest.c
|
|
(define (test-case->string tcase)
|
|
(let ((s (open-output-string))
|
|
(stringify (lambda (v)
|
|
(let ((s (open-output-string)))
|
|
(display v s)
|
|
(get-output-string s)))))
|
|
(display (car tcase) s)
|
|
(display ":" s)
|
|
(display (join-strings "," (map stringify (cadr tcase)))
|
|
s)
|
|
(display ":" s)
|
|
(display (join-strings "," (map stringify (caddr tcase)))
|
|
s)
|
|
(get-output-string s)))
|
|
|
|
(define qadd (make-test-case-generator
|
|
'qadd (make-backref-generator 0.3 0.2) +))
|
|
(define qsub (make-test-case-generator
|
|
'qsub (make-backref-generator 0.3 0.2) -))
|
|
(define qmul (make-test-case-generator
|
|
'qmul (make-backref-generator 0.3 0.2) *))
|
|
(define qdiv (make-test-case-generator
|
|
'qdiv (make-backref-generator 0.3 0.2) /))
|
|
(define qtodec (make-test-case-generator
|
|
'qtodec (make-output-test-generator 0.3 25)
|
|
(lambda (a b) '?)))
|
|
(define qaddz (make-test-case-generator
|
|
'qaddz (make-backref-generator-2 0.3 0.2) +))
|
|
(define qsubz (make-test-case-generator
|
|
'qsubz (make-backref-generator-2 0.3 0.2) -))
|
|
(define qmulz (make-test-case-generator
|
|
'qmulz (make-backref-generator-2 0.3 0.2) *))
|
|
(define qdivz (make-test-case-generator
|
|
'qdivz (make-backref-generator-2 0.3 0.2) /))
|
|
|
|
(define (write-test-cases test-fn lo-size hi-size num-each fname)
|
|
(let ((out (open-output-file fname)))
|
|
(do ((num lo-size (+ num 1)))
|
|
((> num hi-size) (void))
|
|
(do ((den hi-size (- den 1)))
|
|
((< den lo-size) (void))
|
|
(do ((ctr 1 (+ ctr 1)))
|
|
((> ctr num-each) (void))
|
|
(display (test-case->string (test-fn num den)) out)
|
|
(newline out))))
|
|
(close-output-port out)))
|
|
|
|
(define (write-lots-of-tests)
|
|
(write-test-cases qadd 1 20 2 "qadd.tc")
|
|
(write-test-cases qsub 1 20 2 "qsub.tc")
|
|
(write-test-cases qmul 1 20 2 "qmul.tc")
|
|
(write-test-cases qdiv 1 20 2 "qdiv.tc")
|
|
(write-test-cases qtodec 1 20 2 "qtodec.tc")
|
|
(write-test-cases qaddz 1 20 2 "qaddz.tc")
|
|
(write-test-cases qsubz 1 20 2 "qsubz.tc")
|
|
(write-test-cases qmulz 1 20 2 "qmulz.tc")
|
|
(write-test-cases qdivz 1 20 2 "qdivz.tc"))
|