diff --git a/extra/math/extras/extras-docs.factor b/extra/math/extras/extras-docs.factor index 717dc29ca4..b6883d175e 100644 --- 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 a815283f7d..58e0744430 100644 --- 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 6888226e15..7762713584 100644 --- 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