From c7d035ae1a729232579a0fe41ed5affa131d3623 Mon Sep 17 00:00:00 2001
From: Bryan Newbold <bnewbold@robocracy.org>
Date: Mon, 20 Feb 2017 00:05:27 -0800
Subject: Import Upstream version 5d9

---
 bench.scm | 99 ++++++++++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 76 insertions(+), 23 deletions(-)

(limited to 'bench.scm')

diff --git a/bench.scm b/bench.scm
index 2d1cc07..4262564 100644
--- a/bench.scm
+++ b/bench.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1996, 1997, 2001 Free Software Foundation, Inc.
+;; Copyright (C) 1996, 1997, 2001, 2002 Free Software Foundation, Inc.
 ;; 
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -38,11 +38,17 @@
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.  
 
-;;;; "bench.scm", Scheme benchmark computing digits of pi.
+;;;; "bench.scm", Scheme benchmarks: digits of pi and random statistics.
 ;;; Author: Aubrey Jaffer.
 
-(load (in-vicinity (implementation-vicinity) "pi.scm"))
 (require 'transcript)
+(require-if 'inexact 'root)
+(require-if 'inexact 'printf)
+(require 'random)
+(require 'array)
+;;(load (in-vicinity (implementation-vicinity) "prng-v.scm"))
+
+(load (in-vicinity (implementation-vicinity) "pi.scm"))
 (define isqrt
   (cond ((provided? 'inexact) sqrt)
 	(else (require 'root) integer-sqrt)))
@@ -51,26 +57,23 @@
 	(else quotient)))
 (define around
   (cond ((provided? 'inexact)
-	 (lambda (x bnd)
-	   (cond ((>= 99999 (abs x) bnd) (inexact->exact (round x)))
-		 ((> (abs x) 99999) (round x))
-		 (else x))))
-	(else (lambda (x bnd) x))))
+	 (let ()
+	   (require 'printf)
+	   (lambda (x prec) (sprintf #f "%.*g" prec x))))
+	(else (lambda (x prec) x))))
 
-(define (time-pi digits)
+(define (time-call proc . args)
   (let ((start-time (get-internal-run-time)))
-    (pi digits 4)
+    (apply proc args)
     (i/ (* 1000 (- (get-internal-run-time) start-time))
 	internal-time-units-per-second)))
 
-(define (benchmark . arg)
-  (define file
-    (cond ((null? arg) "bench.log")
-	  (else (car arg))))
+(define (benchmark-pi . arg)
+  (define file (if (null? arg) "pi.log" (car arg)))
   (do ((digits 50 (+ digits digits))
-       (t 0 (time-pi (+ digits digits))))
-      ((> t 3000)
-       (do ((tl '() (cons (time-pi digits) tl))
+       (t 0 (time-call pi (+ digits digits) 4)))
+      ((> t 3600)
+       (do ((tl '() (cons (time-call pi digits 4) tl))
 	    (j 12 (+ -1 j)))
 	   ((zero? j)
 	    (let* ((avg (i/ (apply + tl) (length tl)))
@@ -80,18 +83,68 @@
 				   (length tl)))))
 	      (and file (transcript-on file))
 	      (for-each display
-			(list digits " digits took " (around avg 99)
-			      " +/- " (around dev 3) ".ms"))
+			(list digits " digits of pi took " (around avg 4) ".ms"
+			      " +/- " (around dev 2) ".ms"))
 	      (newline)
 	      (let ((scaled-avg (i/ (* (i/ (* avg 1000) digits) 1000) digits))
 		    (scaled-dev (i/ (* (i/ (* dev 1000) digits) 1000) digits)))
 		(for-each display
 			  (list " That is about "
-				(around scaled-avg 99)
+				(around scaled-avg 4) ".ms/(kB)^2"
 				" +/- "
-				(around scaled-dev 3)
-				".ms/(kB)^2"))
+				(around scaled-dev 2) ".ms/(kB)^2"))
 		(newline)
 		(and file (transcript-off)))
 	      ))))))
-(benchmark)
+
+(define (prng samples modu sta)
+  (define sra (create-array (Au32) samples))
+  (do ((cnt (+ -1 samples) (+ -1  cnt))
+       (num (random modu sta) (random modu sta))
+       (sum 0 (+ sum num)))
+      ((negative? cnt)
+       (set! sum (+ sum num))
+       (let ((mean (i/ sum samples)))
+	 (define (square-diff x) (define z (- x mean)) (* z z))
+	 (do ((cnt (+ -1 samples) (+ -1 cnt))
+	      (var2 0 (+ (square-diff (array-ref sra cnt)) var2)))
+	     ((negative? cnt)
+	      (for-each display
+			(list sum " / " samples " = "
+			      mean " +/- " (isqrt (i/ var2 samples))))
+	      (newline)))))
+    (array-set! sra num cnt)))
+
+(define (benchmark-prng . arg)
+  (define file (if (null? arg) "prng.log" (car arg)))
+  (define sta
+    (seed->random-state "http://swissnet.ai.mit.edu/~jaffer/SLIB.html"))
+  (do ((samples 125 (* 4 samples))
+       (t 0 (time-call prng (* 2 samples) 999 sta)))
+      ((or (> t 1000) (and (not (provided? 'bignum)) (> samples 1000)))
+       (do ((tl '() (cons (time-call prng samples 999 sta) tl))
+	    (j 12 (+ -1 j)))
+	   ((zero? j)
+	    (let* ((avg (i/ (apply + tl) (length tl)))
+		   (dev (isqrt (i/ (apply
+				    + (map (lambda (x) (* (- x avg) (- x avg)))
+					   tl))
+				   (length tl)))))
+	      (and file (transcript-on file))
+	      (for-each display
+			(list samples " random samples took " (around avg 4) ".ms"
+			      " +/- " (around dev 2) ".ms"))
+	      (newline)
+	      (let ((scaled-avg (i/ (* avg 1000) samples))
+		    (scaled-dev (i/ (* dev 1000) samples)))
+		(for-each display
+			  (list " That is about "
+				(around scaled-avg 4) ".ms/kB"
+				" +/- "
+				(around scaled-dev 2) ".ms/kB"))
+		(newline)
+		(and file (transcript-off)))))))))
+
+(benchmark-prng)
+(newline)
+(benchmark-pi)
-- 
cgit v1.2.3