;;;
;;; 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"))
Codebase Browser
llvm