diff options
| -rw-r--r-- | mew.scm | 20 | ||||
| -rw-r--r-- | mew.svnwiki | 11 | ||||
| -rw-r--r-- | tests/test.mew | 13 |
3 files changed, 42 insertions, 2 deletions
diff --git a/mew.scm b/mew.scm index 7250d1e..520001f 100644 --- a/mew.scm +++ b/mew.scm @@ -2,7 +2,7 @@ (export act accumulate andloc at boolean - comp + comp cross-product dec def del-at div empty? eof esc fail fin final for fun* @@ -14,7 +14,7 @@ len loc mod negate - one-of op op* + odometer one-of op op* per prn proj puts range rep scan scan-right sing? search seq set set-at str slurp @@ -493,6 +493,22 @@ (define (final g) (generator-fold (lambda (x a) x) (void) g)) + (define (odometer . wheels) + (define (grepeat rep gen) + (gconcatenate (gmap (lambda (item) + (gtake (cycle item) rep)) + gen))) + (if (null? wheels) + (generator) + (match-let (((total . parts) (scan-right * 1 wheels))) + (gtake (apply gmap list (map (lambda (r i) + (grepeat r (gmap (op mod _ i) (range 0)))) + parts wheels)) + total)))) + + (define (cross-product . xs) + (gmap (op map get xs _) (apply odometer (map len xs)))) + (define-syntax and-apply (syntax-rules () ((_ x f args ...) diff --git a/mew.svnwiki b/mew.svnwiki index 3968b98..f11e5d6 100644 --- a/mew.svnwiki +++ b/mew.svnwiki @@ -446,6 +446,17 @@ by {{gen}}) and folds the function {{<f>}} over its values. If given, folding starts with {{<init>}}, else with the first element yielded by the generator. If the generator is empty, return {{(<f>)}}. +<procedure>(odometer <wheels>...)</procedure> + +Returns a generator that takes a list of numbers and yields all +combinations of numbers such that each is below it's wheel. The +rightmost number changes most quickly. + +<procedure>(cross-product <obj>...)</procedure> + +Returns a generator that takes multiple lists/vectors/strings and +yields all elements of their cartesian product (as lists). + == Regular expressions diff --git a/tests/test.mew b/tests/test.mew index b08bfd6..328e282 100644 --- a/tests/test.mew +++ b/tests/test.mew @@ -357,6 +357,19 @@ (test 3 (final (generator 1 2 3))) (test #t (void? (final (generator))))) +(test-group "odometer" + (test '((0 0) (0 1) (0 2) (1 0) (1 1) (1 2)) (into '() (odometer 2 3))) + (test '((0) (1) (2)) (into '() (odometer 3))) + (test '() (into '() (odometer))) + (test 1365 (len (odometer 3 5 7 13)))) + +(test-group "cross-product" + (test '((a X) (a Y) (b X) (b Y) (c X) (c Y)) + (into '() (cross-product '(a b c) '(X Y)))) + (test '((a) (b) (c)) + (into '() (cross-product '(a b c)))) + (test '() (into '() (cross-product)))) + ; -> ; fun-> |