Commits

Anonymous committed 1c356d6

added gen-series API and more type annotations

Comments (0)

Files changed (2)

data-generators-impl.scm

 
 
 ;;== random primitives
+;; get a random integer uniformly
 (: %random-fixnum ((or fixnum float) (or fixnum float) -> fixnum))
 (define (%random-fixnum lo hi)
   (let ((range (- hi lo -1)))
     (inexact->exact (+ (bsd:random-integer range) lo))))
 
-;; currently this only return flonums
 (: %random-real (float float -> float))
 (define (%random-real #!optional (size 1.0) (start 0.0))
   (let ((ub (+ size start)))
    (else lower)))
 
 ;;== ranges are used to configure some generators
+(: range (forall (start (stop *)) (start stop -> (pair start stop))))
 (define (range start stop)
   (cond
    ((and (not start) stop) (cons (gen-current-fixnum-min) stop))
    ((and start (not stop)) (cons start (gen-current-fixnum-max)))
    (else (cons start stop))))
 
+(: range? (* -> boolean))
 (define range? pair?)
+
+(: range-start (forall (e (p (pair e e))) (p -> e)))
 (define range-start car)
+
+(: range-end (forall (e (p (pair e e))) (p -> e)))
 (define range-end cdr)
 
 ;;== generator implementation
 
 (define generator? procedure?)
 
-
-
 ;;== accessing elements from a generator
 (define <-
   (case-lambda
 
 (register-generator-for-type! flonum? gen-real)
 
-
 (define gen-series
   (case-lambda
     (() (gen-series (gen-current-fixnum-min) (gen-current-fixnum-max) add1))
      (let ((next lower))
        (generator
         (let ((actual next))
-          (set! next (if (> actual upper) lower (step actual)))
-          actual))))))
+          (set! next (if (>= actual upper) lower (step actual)))
+          (min actual upper)))))))
 
 (: gen-bool (-> (procedure () boolean)))
 (define (gen-bool)
 (test-group "gen-series"
             (test "works for integers"
              (list 1 2 3 4)
-             (<- 4 (gen-series 1 4 add1))))
+             (<- 4 (gen-series 1 4 add1)))
+            (test "restarts"
+                  (list 1 2 1 2)
+                  (<- 4 (gen-series 1 2 add1))))
 
 (test-group "gen-char"
     (test-assert