From 4a29e2e70741953345c05f166decc975ae9cbe7a Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <ehrenbed@carleton.edu>
Date: Sat, 8 Dec 2007 00:16:26 -0500
Subject: [PATCH] Functions added to sequences.lib; used in shufflers
---
extra/sequences/lib/lib-tests.factor | 6 ++++-
extra/sequences/lib/lib.factor | 34 ++++++++++++++++++++++++++--
extra/shufflers/shufflers.factor | 15 ++----------
3 files changed, 39 insertions(+), 16 deletions(-)
diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor
index 82e2b911c3..72cf9ad9c4 100644
--- a/extra/sequences/lib/lib-tests.factor
+++ b/extra/sequences/lib/lib-tests.factor
@@ -1,5 +1,5 @@
USING: arrays kernel sequences sequences.lib math
-math.functions tools.test ;
+math.functions tools.test strings ;
[ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
[ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@@ -42,3 +42,7 @@ math.functions tools.test ;
[ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
[ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
+
+[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
+[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
+[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index e090feffea..f5adccf445 100644
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -1,5 +1,5 @@
-USING: combinators.lib kernel sequences math namespaces
-random sequences.private shuffle ;
+USING: combinators.lib kernel sequences math namespaces assocs
+random sequences.private shuffle math.functions mirrors ;
IN: sequences.lib
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -74,3 +74,33 @@ IN: sequences.lib
[ not ] compose
[ find drop [ head-slice ] when* ] curry
[ dup ] swap compose keep like ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<PRIVATE
+: translate-string ( n alphabet out-len -- seq )
+ [ drop /mod ] curry* map nip ;
+
+: map-alphabet ( alphabet seq[seq] -- seq[seq] )
+ [ [ swap nth ] curry* map ] curry* map ;
+
+: exact-number-strings ( n out-len -- seqs )
+ [ ^ ] 2keep [ translate-string ] 2curry map ;
+
+: number-strings ( n max-length -- seqs )
+ 1+ [ exact-number-strings ] curry* map concat ;
+PRIVATE>
+
+: exact-strings ( alphabet length -- seqs )
+ >r dup length r> exact-number-strings map-alphabet ;
+
+: strings ( alphabet length -- seqs )
+ >r dup length r> number-strings map-alphabet ;
+
+: nths ( nths seq -- subseq )
+ ! nths is a sequence of ones and zeroes
+ >r [ length ] keep [ nth 1 = ] curry subset r>
+ [ nth ] curry { } map-as ;
+
+: power-set ( seq -- subsets )
+ 2 over length exact-number-strings swap [ nths ] curry map ;
diff --git a/extra/shufflers/shufflers.factor b/extra/shufflers/shufflers.factor
index e0c5141029..95567da2ef 100644
--- a/extra/shufflers/shufflers.factor
+++ b/extra/shufflers/shufflers.factor
@@ -1,25 +1,14 @@
USING: kernel sequences words math math.functions arrays
shuffle quotations parser math.parser strings namespaces
-splitting effects ;
+splitting effects sequences.lib ;
IN: shufflers
: shuffle>string ( names shuffle -- string )
swap [ [ nth ] curry map ] curry map
first2 "-" swap 3append >string ;
-: translate ( n alphabet out-len -- seq )
- [ drop /mod ] curry* map nip ;
-
-: (combinations) ( alphabet out-len -- seq[seq] )
- [ ^ ] 2keep [ translate ] 2curry map ;
-
-: combinations ( n max-out -- seq[seq] )
- ! This returns a seq of length O(n^m)
- ! where and m is max-out
- 1+ [ (combinations) ] curry* map concat ;
-
: make-shuffles ( max-out max-in -- shuffles )
- [ 1+ dup rot combinations [ 2array ] curry* map ]
+ [ 1+ dup rot strings [ 2array ] curry* map ]
curry* map concat ;
: shuffle>quot ( shuffle -- quot )