aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorpukkamustard <pukkamustard@posteo.net>2020-10-27 11:29:39 +0100
committerpukkamustard <pukkamustard@posteo.net>2020-10-27 11:29:39 +0100
commitf74c66a463d0819da49f979bcdd424fc45d438de (patch)
tree0d7d994a9ee30f3dac4db08da9ac359c620a8e2f
parent8c0f863e2e9c7ac80da5d44fec1e3cde2ee422c4 (diff)
(tests eris): use sodium's crypto-stream-chacha20-ietf as pseudo-random
generator for test cases This make test cases deterministic and removes dependency on srfi-158 and srfi-194.
-rw-r--r--Makefile.am7
-rw-r--r--guix.scm4
-rw-r--r--hall.scm9
-rw-r--r--srfi/srfi-158.scm710
-rw-r--r--srfi/srfi-194.scm354
-rw-r--r--tests/eris.scm60
-rw-r--r--tests/utils.scm19
7 files changed, 45 insertions, 1118 deletions
diff --git a/Makefile.am b/Makefile.am
index a51957b..401f423 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -42,12 +42,9 @@ SOURCES = eris.scm \
eris/utils/padding.scm \
eris/utils/base32.scm \
eris/utils/rbytevector.scm \
- eris/block-storage/hash-table.scm \
- srfi/srfi-158.scm \
- srfi/srfi-194.scm
+ eris/block-storage/hash-table.scm
-TESTS = tests/eris.scm \
- tests/utils.scm
+TESTS = tests/eris.scm
TEST_EXTENSIONS = .scm
SCM_LOG_DRIVER = \
diff --git a/guix.scm b/guix.scm
index 624a1c7..7ed05c6 100644
--- a/guix.scm
+++ b/guix.scm
@@ -23,9 +23,9 @@
(method git-fetch)
(uri (git-reference
(url "https://gitlab.com/openengiadina/guile-sodium")
- (commit "0344d63de6035f8e666085f88a49ffdcbaf0e7e5")))
+ (commit "b89828e596bdbea0d0588aef3b1f4850d889e88d")))
(file-name (git-file-name name version))
- (sha256 (base32 "00pr4j1biiklcr4q3x38fi45md866bql57aq2aima826jfkwws05"))))
+ (sha256 (base32 "1mlvf3rgzclhps972y51mqy1dgpif454gxx4k1d5nb10rk7a9jdx"))))
(build-system gnu-build-system)
(arguments `())
(native-inputs
diff --git a/hall.scm b/hall.scm
index f691241..3831b3e 100644
--- a/hall.scm
+++ b/hall.scm
@@ -25,15 +25,10 @@
(scheme-file "rbytevector")))
(directory
"block-storage"
- ((scheme-file "hash-table")))))
- (directory
- "srfi"
- ((scheme-file "srfi-158")
- (scheme-file "srfi-194")))))
+ ((scheme-file "hash-table")))))))
(tests ((directory
"tests"
- ((scheme-file "eris")
- (scheme-file "utils")))))
+ ((scheme-file "eris")))))
(programs
((directory "scripts" ((in-file "eris")))))
(documentation
diff --git a/srfi/srfi-158.scm b/srfi/srfi-158.scm
deleted file mode 100644
index dbf9bdc..0000000
--- a/srfi/srfi-158.scm
+++ /dev/null
@@ -1,710 +0,0 @@
-;; srfi-158.scm - Generators and Accumulators
-
-;; Copyright (C) Shiro Kawai, John Cowan, Thomas Gilray (2015). All Rights Reserved.
-
-;; Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
-
-;; The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.
-
-;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-;;; Commentary:
-
-;;; This is the code of the reference implementation of SRFI-158 with following modifications:
-;;; - bytevector-accumulator accepts bytevectors (instead of only integers)
-;;; - gaccumulate accumulate values from generator
-;;; - port->bytevector-generator
-;;; - gbind
-
-;;; Code:
-
-(define-module (srfi srfi-158)
- #:use-module (rnrs bytevectors)
- #:use-module (rnrs io ports)
- #:use-module (srfi srfi-11)
- #:export (generator
- circular-generator
- make-iota-generator
- make-range-generator
- make-coroutine-generator
- list->generator
- vector->generator
- reverse-vector->generator
- string->generator
- bytevector->generator
- port->bytevector-generator
- make-for-each-generator
- make-unfold-generator
-
- gcons*
- gappend
- gcombine
- gfilter
- gremove
- gtake
- gdrop
- gtake-while
- gdrop-while
- gflatten
- ggroup
- gmerge
- gmap
- gbind
- gstate-filter
- gdelete
- gdelete-neighbor-dups
- gindex
- gselect
- gaccumulate
-
- generator->list
- generator->reverse-list
- generator->vector
- generator->vector!
- generator->string
- generator-fold
- generator-map->list
- generator-for-each
- generator-find
- generator-count
- generator-any
- generator-every
- generator-unfold
-
- make-accumulator
- count-accumulator
- list-accumulator
- reverse-list-accumulator
- vector-accumulator
- reverse-vector-accumulator
- vector-accumulator!
- string-accumulator
- bytevector-accumulator
- bytevector-accumulator!
- sum-accumulator
- product-accumulator))
-
-
-(define (any pred ls)
- (if (null? (cdr ls))
- (pred (car ls))
- ((lambda (x) (if x x (any pred (cdr ls)))) (pred (car ls)))))
-
-;; list->bytevector
-(define (list->bytevector list)
- (let ((vec (make-bytevector (length list) 0)))
- (let loop ((i 0) (list list))
- (if (null? list)
- vec
- (begin
- (bytevector-u8-set! vec i (car list))
- (loop (+ i 1) (cdr list)))))))
-
-
-;; generator
-(define (generator . args)
- (lambda () (if (null? args)
- (eof-object)
- (let ((next (car args)))
- (set! args (cdr args))
- next))))
-
-;; circular-generator
-(define (circular-generator . args)
- (let ((base-args args))
- (lambda ()
- (when (null? args)
- (set! args base-args))
- (let ((next (car args)))
- (set! args (cdr args))
- next))))
-
-
-;; make-iota-generator
-(define make-iota-generator
- (case-lambda ((count) (make-iota-generator count 0 1))
- ((count start) (make-iota-generator count start 1))
- ((count start step) (make-iota count start step))))
-
-;; make-iota
-(define (make-iota count start step)
- (lambda ()
- (cond
- ((<= count 0)
- (eof-object))
- (else
- (let ((result start))
- (set! count (- count 1))
- (set! start (+ start step))
- result)))))
-
-
-;; make-range-generator
-(define make-range-generator
- (case-lambda ((start end) (make-range-generator start end 1))
- ((start) (make-infinite-range-generator start))
- ((start end step)
- (set! start (- (+ start step) step))
- (lambda () (if (< start end)
- (let ((v start))
- (set! start (+ start step))
- v)
- (eof-object))))))
-
-(define (make-infinite-range-generator start)
- (lambda ()
- (let ((result start))
- (set! start (+ start 1))
- result)))
-
-
-
-;; make-coroutine-generator
-(define (make-coroutine-generator proc)
- (define return #f)
- (define resume #f)
- (define yield (lambda (v) (call/cc (lambda (r) (set! resume r) (return v)))))
- (lambda () (call/cc (lambda (cc) (set! return cc)
- (if resume
- (resume (if #f #f)) ; void? or yield again?
- (begin (proc yield)
- (set! resume (lambda (v) (return (eof-object))))
- (return (eof-object))))))))
-
-
-;; list->generator
-(define (list->generator lst)
- (lambda () (if (null? lst)
- (eof-object)
- (let ((next (car lst)))
- (set! lst (cdr lst))
- next))))
-
-
-;; vector->generator
-(define vector->generator
- (case-lambda ((vec) (vector->generator vec 0 (vector-length vec)))
- ((vec start) (vector->generator vec start (vector-length vec)))
- ((vec start end)
- (lambda () (if (>= start end)
- (eof-object)
- (let ((next (vector-ref vec start)))
- (set! start (+ start 1))
- next))))))
-
-
-;; reverse-vector->generator
-(define reverse-vector->generator
- (case-lambda ((vec) (reverse-vector->generator vec 0 (vector-length vec)))
- ((vec start) (reverse-vector->generator vec start (vector-length vec)))
- ((vec start end)
- (lambda () (if (>= start end)
- (eof-object)
- (let ((next (vector-ref vec (- end 1))))
- (set! end (- end 1))
- next))))))
-
-
-;; string->generator
-(define string->generator
- (case-lambda ((str) (string->generator str 0 (string-length str)))
- ((str start) (string->generator str start (string-length str)))
- ((str start end)
- (lambda () (if (>= start end)
- (eof-object)
- (let ((next (string-ref str start)))
- (set! start (+ start 1))
- next))))))
-
-
-;; bytevector->generator
-(define bytevector->generator
- (case-lambda ((str) (bytevector->generator str 0 (bytevector-length str)))
- ((str start) (bytevector->generator str start (bytevector-length str)))
- ((str start end)
- (lambda () (if (>= start end)
- (eof-object)
- (let ((next (bytevector-u8-ref str start)))
- (set! start (+ start 1))
- next))))))
-
-
-;; port->bytevector-generator
-(define (port->bytevector-generator port count)
- "Returns a generator that repeatedly reads and yields count bytes from port."
- (make-coroutine-generator
- (lambda (yield)
- (let loop ((bv (get-bytevector-n port count)))
- (unless (eof-object? bv)
- (yield bv)
- (loop (get-bytevector-n port count)))))))
-
-;; make-for-each-generator
-;FIXME: seems to fail test
-(define (make-for-each-generator for-each obj)
- (make-coroutine-generator (lambda (yield) (for-each yield obj))))
-
-
-;; make-unfold-generator
-(define (make-unfold-generator stop? mapper successor seed)
- (make-coroutine-generator (lambda (yield)
- (let loop ((s seed))
- (if (stop? s)
- (if #f #f)
- (begin (yield (mapper s))
- (loop (successor s))))))))
-
-
-;; gcons*
-(define (gcons* . args)
- (lambda () (if (null? args)
- (eof-object)
- (if (= (length args) 1)
- ((car args))
- (let ((v (car args)))
- (set! args (cdr args))
- v)))))
-
-
-;; gappend
-(define (gappend . args)
- (lambda () (if (null? args)
- (eof-object)
- (let loop ((v ((car args))))
- (if (eof-object? v)
- (begin (set! args (cdr args))
- (if (null? args)
- (eof-object)
- (loop ((car args)))))
- v)))))
-
-;; gflatten
-(define (gflatten gen)
- (let ((state '()))
- (lambda ()
- (if (null? state) (set! state (gen)))
- (if (eof-object? state)
- state
- (let ((obj (car state)))
- (set! state (cdr state))
- obj)))))
-
-;; ggroup
-(define ggroup
- (case-lambda
- ((gen k)
- (simple-ggroup gen k))
- ((gen k padding)
- (padded-ggroup (simple-ggroup gen k) k padding))))
-
-(define (simple-ggroup gen k)
- (lambda ()
- (let loop ((item (gen)) (result '()) (count (- k 1)))
- (if (eof-object? item)
- (if (null? result) item (reverse result))
- (if (= count 0)
- (reverse (cons item result))
- (loop (gen) (cons item result) (- count 1)))))))
-
-(define (padded-ggroup gen k padding)
- (lambda ()
- (let ((item (gen)))
- (if (eof-object? item)
- item
- (let ((len (length item)))
- (if (= len k)
- item
- (append item (make-list (- k len) padding))))))))
-
-;; gmerge
-(define gmerge
- (case-lambda
- ((<) (error "wrong number of arguments for gmerge"))
- ((< gen) gen)
- ((< genleft genright)
- (let ((left (genleft))
- (right (genright)))
- (lambda ()
- (cond
- ((and (eof-object? left) (eof-object? right))
- left)
- ((eof-object? left)
- (let ((obj right)) (set! right (genright)) obj))
- ((eof-object? right)
- (let ((obj left)) (set! left (genleft)) obj))
- ((< right left)
- (let ((obj right)) (set! right (genright)) obj))
- (else
- (let ((obj left)) (set! left (genleft)) obj))))))
- ((< . gens)
- (apply gmerge <
- (let loop ((gens gens) (gs '()))
- (cond ((null? gens) (reverse gs))
- ((null? (cdr gens)) (reverse (cons (car gens) gs)))
- (else (loop (cddr gens)
- (cons (gmerge < (car gens) (cadr gens)) gs)))))))))
-
-;; gbind
-(define (gbind proc . gs)
- (make-coroutine-generator
- (lambda (yield)
- (apply generator-for-each
- (cons
- (lambda (. objs)
- (generator-for-each yield (apply proc objs)))
- gs)))))
-
-;; gmap
-(define gmap
- (case-lambda
- ((proc) (error "wrong number of arguments for gmap"))
- ((proc gen)
- (lambda ()
- (let ((item (gen)))
- (if (eof-object? item) item (proc item)))))
- ((proc . gens)
- (lambda ()
- (let ((items (map (lambda (x) (x)) gens)))
- (if (any eof-object? items) (eof-object) (apply proc items)))))))
-
-
-;; gcombine
-(define (gcombine proc seed . gens)
- (lambda ()
- (define items (map (lambda (x) (x)) gens))
- (if (any eof-object? items)
- (eof-object)
- (let ()
- (define-values (value newseed) (apply proc (append items (list seed))))
- (set! seed newseed)
- value))))
-
-;; gfilter
-(define (gfilter pred gen)
- (lambda () (let loop ()
- (let ((next (gen)))
- (if (or (eof-object? next)
- (pred next))
- next
- (loop))))))
-
-;; gstate-filter
-(define (gstate-filter proc seed gen)
- (let ((state seed))
- (lambda ()
- (let loop ((item (gen)))
- (if (eof-object? item)
- item
- (let-values (((yes newstate) (proc item state)))
- (set! state newstate)
- (if yes
- item
- (loop (gen)))))))))
-
-
-
-;; gremove
-(define (gremove pred gen)
- (gfilter (lambda (v) (not (pred v))) gen))
-
-
-
-;; gtake
-(define gtake
- (case-lambda ((gen k) (gtake gen k (eof-object)))
- ((gen k padding)
- (make-coroutine-generator (lambda (yield)
- (if (> k 0)
- (let loop ((i 0) (v (gen)))
- (begin (if (eof-object? v) (yield padding) (yield v))
- (if (< (+ 1 i) k)
- (loop (+ 1 i) (gen))
- (eof-object))))
- (eof-object)))))))
-
-
-
-;; gdrop
-(define (gdrop gen k)
- (lambda () (do () ((<= k 0)) (set! k (- k 1)) (gen))
- (gen)))
-
-
-
-;; gdrop-while
-(define (gdrop-while pred gen)
- (define found #f)
- (lambda ()
- (let loop ()
- (let ((val (gen)))
- (cond (found val)
- ((and (not (eof-object? val)) (pred val)) (loop))
- (else (set! found #t) val))))))
-
-
-;; gtake-while
-(define (gtake-while pred gen)
- (lambda () (let ((next (gen)))
- (if (eof-object? next)
- next
- (if (pred next)
- next
- (begin (set! gen (generator))
- (gen)))))))
-
-
-
-;; gdelete
-(define gdelete
- (case-lambda ((item gen) (gdelete item gen equal?))
- ((item gen ==)
- (lambda () (let loop ((v (gen)))
- (cond
- ((eof-object? v) (eof-object))
- ((== item v) (loop (gen)))
- (else v)))))))
-
-
-
-;; gdelete-neighbor-dups
-(define gdelete-neighbor-dups
- (case-lambda ((gen)
- (gdelete-neighbor-dups gen equal?))
- ((gen ==)
- (define firsttime #t)
- (define prev #f)
- (lambda () (if firsttime
- (begin (set! firsttime #f)
- (set! prev (gen))
- prev)
- (let loop ((v (gen)))
- (cond
- ((eof-object? v)
- v)
- ((== prev v)
- (loop (gen)))
- (else
- (set! prev v)
- v))))))))
-
-
-;; gindex
-(define (gindex value-gen index-gen)
- (let ((done? #f) (count 0))
- (lambda ()
- (if done?
- (eof-object)
- (let loop ((value (value-gen)) (index (index-gen)))
- (cond
- ((or (eof-object? value) (eof-object? index))
- (set! done? #t)
- (eof-object))
- ((= index count)
- (set! count (+ count 1))
- value)
- (else
- (set! count (+ count 1))
- (loop (value-gen) index))))))))
-
-
-;; gselect
-(define (gselect value-gen truth-gen)
- (let ((done? #f))
- (lambda ()
- (if done?
- (eof-object)
- (let loop ((value (value-gen)) (truth (truth-gen)))
- (cond
- ((or (eof-object? value) (eof-object? truth))
- (set! done? #t)
- (eof-object))
- (truth value)
- (else (loop (value-gen) (truth-gen)))))))))
-
-;; gaccumulate
-(define (gaccumulate accumulator generator)
- (generator-for-each accumulator generator)
- (accumulator (eof-object)))
-
-;; generator->list
-(define generator->list
- (case-lambda ((gen n)
- (generator->list (gtake gen n)))
- ((gen)
- (reverse (generator->reverse-list gen)))))
-
-;; generator->reverse-list
-(define generator->reverse-list
- (case-lambda ((gen n)
- (generator->reverse-list (gtake gen n)))
- ((gen)
- (generator-fold cons '() gen))))
-
-;; generator->vector
-(define generator->vector
- (case-lambda ((gen) (list->vector (generator->list gen)))
- ((gen n) (list->vector (generator->list gen n)))))
-
-
-;; generator->vector!
-(define (generator->vector! vector at gen)
- (let loop ((value (gen)) (count 0) (at at))
- (cond
- ((eof-object? value) count)
- ((>= at (vector-length vector)) count)
- (else (begin
- (vector-set! vector at value)
- (loop (gen) (+ count 1) (+ at 1)))))))
-
-
-;; generator->string
-(define generator->string
- (case-lambda ((gen) (list->string (generator->list gen)))
- ((gen n) (list->string (generator->list gen n)))))
-
-
-
-
-;; generator-fold
-(define (generator-fold f seed . gs)
- (define (inner-fold seed)
- (let ((vs (map (lambda (g) (g)) gs)))
- (if (any eof-object? vs)
- seed
- (inner-fold (apply f (append vs (list seed)))))))
- (inner-fold seed))
-
-
-
-;; generator-for-each
-(define (generator-for-each f . gs)
- (let loop ()
- (let ((vs (map (lambda (g) (g)) gs)))
- (if (any eof-object? vs)
- (if #f #f)
- (begin (apply f vs)
- (loop))))))
-
-
-(define (generator-map->list f . gs)
- (let loop ((result '()))
- (let ((vs (map (lambda (g) (g)) gs)))
- (if (any eof-object? vs)
- (reverse result)
- (loop (cons (apply f vs) result))))))
-
-
-;; generator-find
-(define (generator-find pred g)
- (let loop ((v (g)))
- ; A literal interpretation might say it only terminates on #eof if (pred #eof) but I think this makes more sense...
- (if (or (pred v) (eof-object? v))
- v
- (loop (g)))))
-
-
-;; generator-count
-(define (generator-count pred g)
- (generator-fold (lambda (v n) (if (pred v) (+ 1 n) n)) 0 g))
-
-
-;; generator-any
-(define (generator-any pred g)
- (let loop ((v (g)))
- (if (eof-object? v)
- #f
- (if (pred v)
- #t
- (loop (g))))))
-
-
-;; generator-every
-(define (generator-every pred g)
- (let loop ((v (g)))
- (if (eof-object? v)
- #t
- (if (pred v)
- (loop (g))
- #f ; the spec would have me return #f, but I think it must simply be wrong...
- ))))
-
-
-;; generator-unfold
-(define (generator-unfold g unfold . args)
- (apply unfold eof-object? (lambda (x) x) (lambda (x) (g)) (g) args))
-
-
-;; make-accumulator
-(define (make-accumulator kons knil finalize)
- (let ((state knil))
- (lambda (obj)
- (if (eof-object? obj)
- (finalize state)
- (set! state (kons obj state))))))
-
-
-;; count-accumulator
-(define (count-accumulator) (make-accumulator
- (lambda (obj state) (+ 1 state)) 0 (lambda (x) x)))
-
-;; list-accumulator
-(define (list-accumulator) (make-accumulator cons '() reverse))
-
-;; reverse-list-accumulator
-(define (reverse-list-accumulator) (make-accumulator cons '() (lambda (x) x)))
-
-;; vector-accumulator
-(define (vector-accumulator)
- (make-accumulator cons '() (lambda (x) (list->vector (reverse x)))))
-
-;; reverse-vector-accumulator
-(define (reverse-vector-accumulator)
- (make-accumulator cons '() list->vector))
-
-;; vector-accumulator!
-(define (vector-accumulator! vec at)
- (lambda (obj)
- (if (eof-object? obj)
- vec
- (begin
- (vector-set! vec at obj)
- (set! at (+ at 1))))))
-
-;; bytevector-accumulator
-(define (bytevector-accumulator)
- (make-accumulator
-
- (lambda (obj port-get-bytevector)
- (cond
- ((bytevector? obj)
- (put-bytevector (car port-get-bytevector) obj))
-
- ((integer? obj)
- (put-u8 (car port-get-bytevector) obj)))
- port-get-bytevector)
-
- (let-values (((port get-bytevector) (open-bytevector-output-port)))
- (cons port get-bytevector))
-
- (lambda (port-get-bytevector)
- (apply (cdr port-get-bytevector) '()))))
-
-(define (bytevector-accumulator! bytevec at)
- (lambda (obj)
- (if (eof-object? obj)
- bytevec
- (begin
- (bytevector-u8-set! bytevec at obj)
- (set! at (+ at 1))))))
-
-;; string-accumulator
-(define (string-accumulator)
- (make-accumulator cons '()
- (lambda (lst) (list->string (reverse lst)))))
-
-;; sum-accumulator
-(define (sum-accumulator) (make-accumulator + 0 (lambda (x) x)))
-
-;; product-accumulator
-(define (product-accumulator) (make-accumulator * 1 (lambda (x) x)))
-
diff --git a/srfi/srfi-194.scm b/srfi/srfi-194.scm
deleted file mode 100644
index d96895d..0000000
--- a/srfi/srfi-194.scm
+++ /dev/null
@@ -1,354 +0,0 @@
-;; srfi-194.scm - Random data generators
-
-;;; Commentary:
-
-;;; This is the code of the reference implementation of SRFI-194 (in draft)
-
-(define-module (srfi srfi-194)
- #:use-module (srfi srfi-27)
- #:use-module (srfi srfi-43)
- #:use-module (srfi srfi-158)
- #:use-module (rnrs base)
- #:use-module (rnrs io ports)
- #:export (make-random-integer-generator
-
- make-random-u8-generator
- make-random-s8-generator
- make-random-u16-generator
- make-random-s16-generator
- make-random-u32-generator
- make-random-s32-generator
- make-random-u64-generator
- make-random-s64-generator
-
- make-random-boolean-generator
- make-random-char-generator
- make-random-string-generator
- make-random-real-generator
-
- make-normal-generator
- make-exponential-generator
- make-geometric-generator
- make-poisson-generator
-
- gsampling
- gweighted-sampling))
-
-;;; Code:
-
-;;
-;; Primitive randoms
-;;
-
-(define make-random-integer-generator
- (case-lambda
- ((low-bound up-bound)
- (make-random-integer-generator default-random-source low-bound up-bound))
- ((rand-src low-bound up-bound)
- (when (not (random-source? rand-src))
- (error "expected random-source"))
- (when (not (integer? low-bound))
- (error "expected integer"))
- (when (not (integer? up-bound))
- (error "expected integer"))
- (let ((rand-int-proc (random-source-make-integers rand-src))
- (range (- up-bound low-bound)))
- (lambda ()
- (+ low-bound (rand-int-proc range)))))))
-
-;private
-(define (make-int-generator-maker low-bound up-bound)
- (case-lambda
- (() (make-random-integer-generator low-bound up-bound))
- ((s) (make-random-integer-generator s low-bound up-bound))))
-
-(define make-random-u8-generator (make-int-generator-maker 0 256))
-(define make-random-s8-generator (make-int-generator-maker -128 128))
-(define make-random-u16-generator (make-int-generator-maker 0 65536))
-(define make-random-s16-generator (make-int-generator-maker -32768 32768))
-(define make-random-u32-generator (make-int-generator-maker 0 (expt 2 32)))
-(define make-random-s32-generator (make-int-generator-maker (- (expt 2 31)) (expt 2 31)))
-(define make-random-u64-generator (make-int-generator-maker 0 (expt 2 64)))
-(define make-random-s64-generator (make-int-generator-maker (- (expt 2 63)) (expt 2 63)))
-
-(define make-random-boolean-generator
- (case-lambda
- (() (make-random-boolean-generator default-random-source))
- ((s)
- (let ((int-gen (make-random-integer-generator s 0 2)))
- (lambda ()
- (zero? (int-gen)))))))
-
-(define make-random-char-generator
- (case-lambda
- ((str)
- (make-random-char-generator default-random-source str))
- ((rand-src str)
- (when (not (random-source? rand-src))
- (error "expected random-source"))
- (when (not (string? str))
- (error "expected string"))
- (let* ((int-gen (make-random-integer-generator rand-src 0 (string-length str))))
- (lambda ()
- (string-ref str (int-gen)))))))
-
-(define make-random-string-generator
- (case-lambda
- ((k str) (make-random-string-generator default-random-source k str))
- ((s k str)
- (let ((char-gen (make-random-char-generator s str))
- (int-gen (make-random-integer-generator s 0 k)))
- (lambda ()
- (generator->string char-gen (int-gen)))))))
-
-(define make-random-real-generator
- (case-lambda
- ((low-bound up-bound)
- (make-random-real-generator default-random-source low-bound up-bound))
- ((rand-src low-bound up-bound)
- (let* ((rand-int-proc (random-source-make-integers rand-src))
- (steps (expt 2 32))
- (rand-real-proc (lambda ()
- (/ (inexact (rand-int-proc steps))
- (- steps 1))))
- (range (- up-bound low-bound)))
- (lambda ()
- (+ low-bound (* (rand-real-proc) range)))))))
-
-;;
-;; Non-uniform distributions
-;;
-
-;; TODO import from somewhere?
-(define PI (* 4 (atan 1.0)))
-
-(define make-normal-generator
- (case-lambda
- (()
- (make-normal-generator default-random-source 0.0 1.0))
- ((arg1)
- (cond
- ((random-source? arg1)
- (make-normal-generator arg1 0.0 1.0))
- (else (make-normal-generator default-random-source arg1 1.0))))
- ((arg1 arg2)
- (cond
- ((and (random-source? arg1)
- (number? arg2))
- (make-normal-generator arg1 arg2 1.0))
- ((and (number? arg1)
- (number? arg2))
- (make-normal-generator default-random-source arg1 arg2))
- (else (error "expected random-source and mean, or mean and standard deviation"))))
- ((rand-src mean deviation)
- (let ((rand-real-proc (random-source-make-reals rand-src)))
- (lambda ()
- ;;Box-Muller
- (let ((r (sqrt (* -2 (log (rand-real-proc)))))
- (theta (* 2 PI (rand-real-proc))))
- (+ mean (* deviation r (sin theta)))))))))
-
-(define make-exponential-generator
- (case-lambda
- ((mean)
- (make-exponential-generator default-random-source mean))
- ((rand-src mean)
- (let ((rand-real-proc (random-source-make-reals rand-src)))
- (lambda ()
- (- (* mean (log (rand-real-proc)))))))))
-
-(define make-geometric-generator
- (case-lambda
- ((p)
- (make-geometric-generator default-random-source p))
- ((rand-src p)
- (let ((c (/ (log (- 1.0 p))))
- (rand-real-proc (random-source-make-reals rand-src)))
- (lambda ()
- (ceiling (* c (log (rand-real-proc)))))))))
-
-(define make-poisson-generator
- (case-lambda
- ((L)
- (make-poisson-generator default-random-source L))
- ((rand-src L)
- (let ((rand-real-proc (random-source-make-reals rand-src)))
- (if (< L 36)
- (make-poisson/small rand-real-proc L)
- (make-poisson/large rand-real-proc L))))))
-
-;private
-(define (make-poisson/small rand-real-proc L)
- (lambda ()
- (do ((exp-L (exp (- L)))
- (k 0 (+ k 1))
- (p 1.0 (* p (rand-real-proc))))
- ((<= p exp-L) (- k 1)))))
-
-;private
-(define (make-poisson/large rand-real-proc L)
- (let* ((c (- 0.767 (/ 3.36 L)))
- (beta (/ PI (sqrt (* 3 L))))
- (alpha (* beta L))
- (k (- (log c) L (log beta))))
- (define (loop)
- (let* ((u (rand-real-proc))
- (x (/ (- alpha (log (/ (- 1.0 u) u))) beta))
- (n (exact (floor (+ x 0.5)))))
- (if (< n 0)
- (loop)
- (let* ((v (rand-real-proc))
- (y (- alpha (* beta x)))
- (t (+ 1.0 (exp y)))
- (lhs (+ y (log (/ v (* t t)))))
- (rhs (+ k (* n (log L)) (- (log-of-fact n)))))
- (if (<= lhs rhs)
- n
- (loop))))))
- loop))
-
-;private
-;log(n!) table for n 1 to 256. Vector, where nth index corresponds to log((n+1)!)
-;Computed on first invocation of `log-of-fact`
-(define log-fact-table #f)
-
-;private
-;computes log-fact-table
-;log(n!) = log((n-1)!) + log(n)
-(define (make-log-fact-table!)
- (define table (make-vector 256))
- (vector-set! table 0 0)
- (do ((i 1 (+ i 1)))
- ((> i 255) #t)
- (vector-set! table i (+ (vector-ref table (- i 1))
- (log (+ i 1)))))
- (set! log-fact-table table))
-
-;private
-;returns log(n!)
-;adapted from https://www.johndcook.com/blog/2010/08/16/how-to-compute-log-factorial/
-(define (log-of-fact n)
- (when (not log-fact-table)
- (make-log-fact-table!))
- (cond
- ((<= n 1) 0)
- ((<= n 256) (vector-ref log-fact-table (- n 1)))
- (else (let ((x (+ n 1)))
- (+ (* (- x 0.5)
- (log x))
- (- x)
- (* 0.5
- (log (* 2 PI)))
- (/ 1.0 (* x 12.0)))))))
-
-
-(define (gsampling . args)
- (cond
- ((null? args) (gsampling* default-random-source '()))
- ((random-source? (car args)) (gsampling* (car args) (cdr args)))
- (else (gsampling* default-random-source args))))
-
-;private
-(define (gsampling* s generators-lst)
- (let ((gen-vec (list->vector generators-lst))
- (rand-int-proc (random-source-make-integers s)))
-
- ;remove exhausted generator at index
- (define (remove-gen index)
- (define new-vec (make-vector (- (vector-length gen-vec) 1)))
- ;when removing anything but first, copy all elements before index
- (when (> index 0)
- (vector-copy! new-vec 0 gen-vec 0 index))
- ;when removing anything but last, copy all elements after index
- (when (< index (- (vector-length gen-vec) 1))
- (vector-copy! new-vec index gen-vec (+ 1 index)))
- (set! gen-vec new-vec))
-
- ;randomly pick generator. If it's exhausted remove it, and pick again
- ;returns value (or eof, if all generators are exhausted)
- (define (pick)
- (let* ((index (rand-int-proc (vector-length gen-vec)))
- (gen (vector-ref gen-vec index))
- (value (gen)))
- (if (eof-object? value)
- (begin
- (remove-gen index)
- (if (= (vector-length gen-vec) 0)
- (eof-object)
- (pick)))
- value)))
-
- (lambda ()
- (if (= 0 (vector-length gen-vec))
- (eof-object)
- (pick)))))
-
-(define (gweighted-sampling . args)
- (cond
- ((null? args) (gweighted-sampling* default-random-source '()))
- ((random-source? (car args)) (gweighted-sampling* (car args) (group-weights-with-generators (cdr args))))
- (else (gweighted-sampling* default-random-source (group-weights-with-generators args)))))
-
-;private
-(define (group-weights-with-generators objs)
- (let loop ((objs objs)
- (pairs '()))
- (cond
- ((null? objs) (reverse pairs))
- (else (begin
- (when (null? (cdr objs))
- (error "Uneven amount of arguments provided"))
- (when (not (number? (car objs)))
- (error "Expected number"))
- (when (< (car objs) 0)
- (error "Weight cannot be negative"))
- (loop (cddr objs)
- (cons (cons (car objs) (cadr objs))
- pairs)))))))
-
-;private
-(define (gweighted-sampling* s weight+generators-lst)
- (let ((weight-sum (apply + (map car weight+generators-lst)))
- (rand-real-proc (random-source-make-reals s)))
-
- ;randomly pick generator. If it's exhausted remove it, and pick again.
- ;returns value (or eof, if all generators are exhausted)
- (define (pick)
- (let* ((roll (* (rand-real-proc) weight-sum))
- (picked+rest-gens (pick-weighted-generator roll weight+generators-lst))
- (picked-gen (car picked+rest-gens))
- (value ((cdr picked-gen))))
- (if (eof-object? value)
- (begin
- (set! weight+generators-lst (cdr picked+rest-gens))
- (set! weight-sum (apply + (map car weight+generators-lst)))
- (if (null? weight+generators-lst)
- (eof-object)
- (pick)))
- value)))
-
- (lambda ()
- (if (null? weight+generators-lst)
- (eof-object)
- (pick)))))
-
-;private
-;returns pair, where car is picked generator, and cdr is list of rest generators in preserved order
-(define (pick-weighted-generator roll weight+gen-lst)
- (let loop ((sum 0)
- (weight+gen-lst weight+gen-lst)
- (picked-gen #f)
- (rest-gen-rev '()))
- (if (null? weight+gen-lst)
- (cons picked-gen (reverse rest-gen-rev))
- (let* ((w+g (car weight+gen-lst)))
- (if (or picked-gen
- (< (+ sum (car w+g)) roll))
- (loop (+ sum (car w+g))
- (cdr weight+gen-lst)
- picked-gen
- (cons w+g rest-gen-rev))
- (loop (+ sum (car w+g))
- (cdr weight+gen-lst)
- w+g
- rest-gen-rev))))))
diff --git a/tests/eris.scm b/tests/eris.scm
index 06345d9..96e3568 100644
--- a/tests/eris.scm
+++ b/tests/eris.scm
@@ -13,20 +13,22 @@
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
- #:use-module (tests utils)
+ #:use-module (sodium stream)
+ #:use-module (sodium generichash)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64)
- #:use-module (srfi srfi-158)
#:use-module (srfi srfi-171))
(define my-store (make <eris-block-storage-hash-table>))
(define my-convergence-secret (make-bytevector 32 0))
-;; a random bytevector generator (maximum 1000kB)
-(define random-bytevector-generator
- (make-random-bytevector-generator (* 1024 100)))
+(define null-nonce (make-bytevector 12 0))
+(define* (pseudo-random-bytevector length #:key (seed "Hail ERIS!"))
+ (crypto-stream-chacha20-ietf length
+ null-nonce
+ (crypto-generichash (string->utf8 seed) #:out-len 32)))
(test-begin "eris")
@@ -36,21 +38,37 @@
(eris-encode-uri (open-bytevector-input-port (string->utf8 "Hail ERIS!")))
"urn:erisx2:AAAAV4OIFHWY67XFEHAOQVXUOWTYDVG5TEY6S6IW4PJ4SQLVJJF4MIKNDLKUDPPHDCKLBUIAJQ3U2IEARRPFHEHWFW5NJY7BJUGFESPGDQ")
-(generator-for-each
-
- (lambda (bv)
-
- (let-values (((urn _) (eris-encode (open-bytevector-input-port bv)
- #:block-storage my-store
- #:convergence-secret my-convergence-secret
- #:block-size (* 32 1024))))
-
-
- (test-assert "decoded bytevector is same as initial bytevector"
- (bytevector=?
- bv
- (eris-decode->bytevector urn #:block-storage my-store)))))
-
- (gtake random-bytevector-generator 20))
+(define content-sizes
+ (list 0
+ 1
+ 8
+ 32
+ 1023
+ 1024
+ 424242
+ 31230924
+ (* 10 1024)
+ (* 32 1024)
+ (* 1024 1024)
+ (* 1024 1024 32)
+ (* 1024 1024 100)))
+
+(for-each
+ (lambda (l)
+
+ (let ((bv (pseudo-random-bytevector l)))
+
+ (let-values (((urn _) (eris-encode (open-bytevector-input-port bv)
+ #:block-storage my-store
+ #:convergence-secret my-convergence-secret
+ #:block-size (* 32 1024))))
+
+
+ (test-assert "decoded bytevector is same as initial bytevector"
+ (bytevector=?
+ bv
+ (eris-decode->bytevector urn #:block-storage my-store))))))
+
+ content-sizes)
(test-end "eris")
diff --git a/tests/utils.scm b/tests/utils.scm
deleted file mode 100644
index 9b3f70b..0000000
--- a/tests/utils.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-; SPDX-FileCopyrightText: 2020 pukkamustard <pukkamustard@posteo.net>
-;
-; SPDX-License-Identifier: GPL-3.0-or-later
-
-(define-module (tests utils)
- #:use-module (srfi srfi-158)
- #:use-module (srfi srfi-194)
- #:use-module (rnrs bytevectors)
- #:export (make-random-bytevector-generator))
-
-;; TODO this is slow. Make it faster
-(define (make-random-bytevector-generator max-size)
- (let ((random-u8-generator (make-random-u8-generator))
- (random-size-generator (make-random-integer-generator 0 max-size)))
- (gmap
- (lambda (size)
- (u8-list->bytevector
- (generator->list random-u8-generator size)))
- random-size-generator)))