math.extras: adding more permutation-bits words.

diff --git a/extra/math/extras/extras-docs.factor b/extra/math/extras/extras-docs.factor
index 717dc29ca4bca84c0d1c4f9f1599fd12d7257be9..b6883d175efdda92409aab6d16ea1b6cb94a5c87 100644 (file)
--- a/extra/math/extras/extras-docs.factor
+++ b/extra/math/extras/extras-docs.factor
@@ -91,6 +91,6 @@ HELP: next-permutation-bits
 { $values { "v" integer } { "w" integer } }
 { $description "Generates the next bitwise permutation with the same number of set bits, given a previous lexicographical value." } ;
 
-HELP: permutation-bits
+HELP: all-permutation-bits
 { $values { "bit-count" integer } { "bits" integer } { "seq" sequence } }
 { $description "Generates all permutations of numbers with a given bit-count and number of bits." } ;

diff --git a/extra/math/extras/extras-tests.factor b/extra/math/extras/extras-tests.factor
index a815283f7dc5db965ac5763da8fb401ce3f69d2d..58e0744430633e3297664e822f54675ed99cb6b3 100644 (file)
--- a/extra/math/extras/extras-tests.factor
+++ b/extra/math/extras/extras-tests.factor
@@ -138,4 +138,11 @@ IN: math.extras.test
         0b00111 0b01011 0b01101 0b01110 0b10011
         0b10101 0b10110 0b11001 0b11010 0b11100
     }
-} [ 3 5 permutation-bits ] unit-test
+} [ 3 5 all-permutation-bits ] unit-test
+
+{ { 14 22 26 28 38 42 44 50 52 56 } } [ 3 5 [ 2 * ] map-permutation-bits ] unit-test
+
+{ V{ 14 22 26 28 } } [ 3 5 [ even? ] filter-permutation-bits ] unit-test
+
+{ 14 } [ 3 5 [ even? ] find-permutation-bits ] unit-test
+{ f } [ 3 5 [ 0 < ] find-permutation-bits ] unit-test

diff --git a/extra/math/extras/extras.factor b/extra/math/extras/extras.factor
index 6888226e15ab5cb528e1553008e11112ae517a8d..776271358456dec0412b14bfe30616a978b9d800 100644 (file)
--- a/extra/math/extras/extras.factor
+++ b/extra/math/extras/extras.factor
@@ -261,9 +261,32 @@ M: float round-to-even
 
 : next-permutation-bits ( v -- w )
     [ dup 1 - bitor 1 + dup ] keep
-    [ dup neg bitand ] bi@ /i -1 shift 1 - bitor ;
+    [ dup neg bitand ] bi@ /i 2/ 1 - bitor ;
 
-: permutation-bits ( bit-count bits -- seq )
-    [ on-bits dup '[ dup _ >= ] ]
-    [ on-bits '[ [ next-permutation-bits _ bitand ] keep ] ]
-    bi* produce nip ;
+<PRIVATE
+
+: permutation-bits-quot ( bit-count bits quot -- n pred body )
+    [ [ on-bits dup '[ dup _ >= ] ] [ on-bits ] bi* ] dip swap
+    '[ _ [ next-permutation-bits _ bitand ] bi ] ; inline
+
+PRIVATE>
+
+: each-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ) -- ... )
+    permutation-bits-quot while drop ; inline
+
+: map-permutation-bits ( ... bit-count bits quot: ( ... n -- ... m ) -- ... seq )
+    permutation-bits-quot [ swap ] compose produce nip ; inline
+
+: filter-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ? ) -- ... seq )
+    selector [ each-permutation-bits ] dip ; inline
+
+: all-permutation-bits ( bit-count bits -- seq )
+    [ ] map-permutation-bits ;
+
+: find-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ? ) -- ... elt/f )
+    [ f f ] 3dip [ 2nip ] prepose [ keep swap ] curry
+    permutation-bits-quot [ [ pick not and ] compose ] dip
+    while drop swap and ; inline
+
+: reduce-permutation-bits ( ... bit-count bits identity quot: ( ... prev elt -- ... next ) -- ... result )
+    [ -rot ] dip each-permutation-bits ; inline