add types, fix vector-copy! shadowing

5 files changed, 86 insertions, 14 deletions

diff --git a/194-impl.scm b/194-impl.scm
index ae98046..0d95073 100644
--- a/194-impl.scm
+++ b/194-impl.scm
@@ -2,6 +2,13 @@
 ; SPDX-FileCopyrightText: 2020 Bradley Lucier
 ; SPDX-License-Identifier: MIT
 
+(define-syntax proj1
+  ;; Return the first returned value after evaluating `expr`.
+  (syntax-rules ()
+    ((proj1 expr)
+     (let-values (((returned second) expr))
+       returned))))
+
 ;;
 ;; This parameter is defined by the srfi-27 egg.
 ;;
@@ -23,6 +30,7 @@
 ;; https://doi.org/10.1287/opre.50.6.1073.358
 ;;
 
+(: make-random-source-generator (integer -> (-> *)))
 (define (make-random-source-generator s)
   (if (not (and (exact? s)
                 (integer? s)
@@ -39,29 +47,48 @@
 ;; Primitive randoms
 ;;
 
+(: make-random-integer-generator (integer integer -> (-> integer)))
 (define (make-random-integer-generator low-bound up-bound)
-  (make-uniform-random-integers high: (- up-bound 1)
-                                low: low-bound))
+  (proj1 (make-uniform-random-integers high: (- up-bound 1)
+                                       low: low-bound)))
 
+(: make-random-u1-generator (-> (-> integer)))
 (define (make-random-u1-generator)
   (make-random-integer-generator 0 2))
+
+(: make-random-u8-generator (-> (-> integer)))
 (define (make-random-u8-generator)
   (make-random-integer-generator 0 256))
+
+(: make-random-s8-generator (-> (-> integer)))
 (define (make-random-s8-generator)
   (make-random-integer-generator -128 128))
+
+(: make-random-u16-generator (-> (-> integer)))
 (define (make-random-u16-generator)
   (make-random-integer-generator 0 65536))
+
+(: make-random-s16-generator (-> (-> integer)))
 (define (make-random-s16-generator)
   (make-random-integer-generator -32768 32768))
+
+(: make-random-u32-generator (-> (-> integer)))
 (define (make-random-u32-generator)
   (make-random-integer-generator 0 (expt 2 32)))
+
+(: make-random-s32-generator (-> (-> integer)))
 (define (make-random-s32-generator)
   (make-random-integer-generator (- (expt 2 31)) (expt 2 31)))
+
+(: make-random-u64-generator (-> (-> integer)))
 (define (make-random-u64-generator)
   (make-random-integer-generator 0 (expt 2 64)))
+
+(: make-random-s64-generator (-> (-> integer)))
 (define (make-random-s64-generator)
   (make-random-integer-generator (- (expt 2 63)) (expt 2 63)))
 
+(: clamp-real-number (number number number --> number))
 (define (clamp-real-number lower-bound upper-bound value)
   (cond ((not (real? lower-bound))
          (error "expected real number for lower bound"))
@@ -73,6 +100,8 @@
         ((> value upper-bound) upper-bound)
         (else value)))
 
+(: make-random-real-generator
+   (number number -> (-> float)))
 (define (make-random-real-generator low-bound up-bound)
   (unless (and (real? low-bound)
                (finite? low-bound))
@@ -91,6 +120,8 @@
      (+ (* t low-bound)
         (* (- 1.0 t) up-bound)))))
 
+(: make-random-rectangular-generator
+   (number number number number -> (-> cplxnum)))
 (define (make-random-rectangular-generator
           real-lower-bound real-upper-bound
           imag-lower-bound imag-upper-bound)
@@ -99,6 +130,8 @@
     (lambda ()
       (make-rectangular (real-gen) (imag-gen)))))
 
+;;; TODO: How to type optional arguments that appear in the front in
+;;; CHICKEN?
 (define make-random-polar-generator
   (case-lambda
     ((magnitude-lower-bound magnitude-upper-bound)
@@ -132,8 +165,11 @@
                 (r (sqrt (+ (* m t) b))))
           (+ origin (make-polar r phi))))))))
 
-(define (make-random-boolean-generator) (make-random-bernoullis))
+(: make-random-boolean-generator (-> (-> boolean)))
+(define (make-random-boolean-generator)
+  (proj1 (make-random-bernoullis)))
 
+(: make-random-char-generator (string -> (-> char)))
 (define (make-random-char-generator str)
   (when (not (string? str))
     (error "expected string"))
@@ -143,6 +179,7 @@
    (lambda ()
      (string-ref str (int-gen)))))
 
+(: make-random-string-generator (integer string -> (-> string)))
 (define (make-random-string-generator k str)
   (let ((char-gen (make-random-char-generator str))
         (int-gen (make-random-integer-generator 0 k)))
@@ -153,20 +190,25 @@
 ;; Non-uniform distributions
 ;;
 
+(: PI float)
 (define PI (* 4 (atan 1.0)))
 
+(: make-bernoulli-generator (#!optional number * -> (-> fixnum)))
 (define make-bernoulli-generator
   (case-lambda
     (() (make-bernoulli-generator 1/2 (current-random-real)))
     ((p) (make-bernoulli-generator p (current-random-real)))
     ((p source)
      (gmap (lambda (x) (if x 1 0))
-           (make-random-bernoullis p: p randoms: source)))))
+           (proj1 (make-random-bernoullis p: p randoms: source))))))
 
+(: make-binomial-generator (number number -> (-> number)))
 (define (make-binomial-generator n p)
-  ;; Already in CHICKEN's SRFI-27
-  (make-random-binomials t: n p: p randoms: (current-random-real)))
+  (proj1
+   (make-random-binomials t: n p: p randoms: (current-random-real))))
 
+(: make-categorical-generator
+   ((vector-of number) -> (-> integer)))
 (define (make-categorical-generator weights-vec)
   (define weight-sum
     (vector-fold
@@ -191,14 +233,20 @@
            (it newsum
                (+ i 1)))))))
 
+(: make-normal-generator
+   (#!optional number number -> (-> number)))
 (define make-normal-generator
   (case-lambda
     (() (make-normal-generator #i0 #i1))
     ((mean) (make-normal-generator mean #i1))
     ((mean deviation)
-     (make-random-normals mu: mean sigma: deviation
-                          randoms: (current-random-real)))))
+     (proj1
+      (make-random-normals mu: mean sigma: deviation
+                           randoms: (current-random-real))))))
 
+;;; NOTE: Chicken's SRFI-27 has an exponential generator, but for
+;;; some reason it is limited to means between 0 and 1.
+(: make-exponential-generator (number -> (-> number)))
 (define (make-exponential-generator mean)
   (unless (and (real? mean)
                (finite? mean)
@@ -208,12 +256,17 @@
    (lambda ()
      (- (* mean (log (rand-real-proc)))))))
 
+(: make-geometric-generator (number -> (-> number )))
 (define (make-geometric-generator p)
-  (make-random-geometrics p: p randoms: (current-random-real)))
+  (proj1
+   (make-random-geometrics p: p randoms: (current-random-real))))
 
+(: make-poisson-generator (number -> (-> number)))
 (define (make-poisson-generator L)
-  (make-random-poissons mu: L random: (current-random-real)))
+  (proj1
+   (make-random-poissons mu: L random: (current-random-real))))
 
+(: gsampling (#!rest (-> *) -> (-> *)))
 (define (gsampling . generators-lst)
   (let ((gen-vec (list->vector generators-lst))
         (rand-int-proc (random-source-make-integers (current-random-source))))
diff --git a/194.sld b/194.sld
index 4a8a6b3..50e4609 100644
--- a/194.sld
+++ b/194.sld
@@ -12,7 +12,9 @@
           (srfi 27 uniform-random)
           (srfi 133)
           (srfi 158)
-          (chicken platform))
+          (except (chicken base) vector-copy!)
+          (chicken platform)
+          (chicken type))
   (export
    clamp-real-number
    current-random-source
diff --git a/sphere.scm b/sphere.scm
index 186bab5..ca153c1 100644
--- a/sphere.scm
+++ b/sphere.scm
@@ -14,7 +14,13 @@
 ;;; distributed on an N-dimensional sphere.
 ;;; This implements the BoxMeuller algorithm, that is, of normalizing
 ;;; N+1 Gaussian random variables.
+;;; 
+;;; NOTE: These would be better as f64vectors, but the SRFI uses standard
+;;; Scheme vectors.
 
+(define-type real (or integer float ratnum))
+
+(: make-sphere-generator (fixnum -> (-> (vector-of float))))
 (define (make-sphere-generator arg)
   (cond
    ((and (integer? arg)
@@ -24,6 +30,7 @@
    (else
     (error "make-sphere-generator: The argument must be a positive exact integer: " arg))))
 
+(: make-ellipsoid-generator ((vector-of real) -> (-> (vector-of float))))
 (define (make-ellipsoid-generator arg)
 
   (define (return-error)
@@ -54,6 +61,7 @@
 ;;; and `B`, `C`, `D`, ... are the other axes. Maximum performance
 ;;; is achieved on spheres, which is the case used in make-ball-generator
 
+(: make-ellipsoid-generator* ((vector-of float) -> (-> (vector-of float))))
 (define (make-ellipsoid-generator* axes)
   (let ((gauss (make-normal-generator))
         (uniform (make-random-real-generator 0. 1.)) ;; should really be from a separate stream
@@ -101,6 +109,7 @@
 ;;; which in turn is based on the Harman-Lacko-Voelker Dropped Coordinate method for
 ;;; generating points uniformly inside the unit ball in N dimensions.
 
+(: make-ball-generator ((or fixnum (vector-of real)) -> (-> (vector-of float))))
 (define (make-ball-generator arg)
 
   (define (return-error)
@@ -121,6 +130,7 @@
                 (return-error)))
           (return-error))))
 
+(: make-ball-generator* ((vector-of float) -> (-> (vector-of float))))
 (define (make-ball-generator* axes)
   (let* ((sphere-generator
           ;; returns vectors with (vector-length axes) + 2 elements
diff --git a/srfi-194.egg b/srfi-194.egg
index 81d67ca..c7e75c6 100644
--- a/srfi-194.egg
+++ b/srfi-194.egg
@@ -5,10 +5,11 @@
  (category "data")
  (license "MIT")
  (dependencies "r7rs" "srfi-133" "srfi-27" "srfi-158")
- (test-dependencies "srfi-64")
+ (test-dependencies "test")
  (components (extension srfi-194
                (source "194.sld")
+               (types-file)
                (source-dependencies "194-impl.scm"
                                     "sphere.scm"
                                     "zipf-zri.scm")
-               (csc-options "-R" "r7rs" "-X" "r7rs"))))
+               (csc-options "-O3" "-R" "r7rs" "-X" "r7rs"))))
diff --git a/zipf-zri.scm b/zipf-zri.scm
index 9e0f003..0fac5b8 100644
--- a/zipf-zri.scm
+++ b/zipf-zri.scm
@@ -28,6 +28,8 @@
 ; Accuracy is diminished for |1-s|< 1e-6. The accuracy is roughly
 ; equal to 1e-15 / |1-s| where 1e-15 == 64-bit double-precision ULP.
 ;
+
+(: make-zipf-generator/zri (integer number number -> (-> number)))
 (define (make-zipf-generator/zri n s q)
 
   ; The hat function h(x) = 1 / (x+q)^s
@@ -88,6 +90,8 @@
 ; equal to 0.05 * |1-s|^4 due to exp(1-s) being expanded to 4 terms.
 ;
 ; This handles the special case of s==1 perfectly.
+
+(: make-zipf-generator/one (integer number number -> (-> number)))
 (define (make-zipf-generator/one n s q)
 
   (define _1-s (- 1 s))
@@ -180,7 +184,9 @@
 ; Example usage:
 ;    (define zgen (make-zipf-generator 50 1.01 0))
 ;    (generator->list zgen 10)
-;
+
+(: make-zipf-generator
+   (integer #!optional number number -> (-> number)))
 (define make-zipf-generator
   (case-lambda
     ((n)