extra/math/combinatorics/bits/bits.factor

   1 ! Copyright (C) 2013 John Benediktsson
   2 ! See http://factorcode.org/license.txt for BSD license
   3 USING: fry kernel math math.bitwise sequences ;
   4 IN: math.combinatorics.bits
   5
   6 : next-permutation-bits ( v -- w )
   7     [ dup 1 - bitor 1 + dup ] keep
   8     [ dup neg bitand ] bi@ /i 2/ 1 - bitor ;
   9
  10 <PRIVATE
  11
  12 : permutation-bits-quot ( bit-count bits quot -- n pred body )
  13     [ [ on-bits dup '[ dup _ >= ] ] [ on-bits ] bi* ] dip swap
  14     '[ _ [ next-permutation-bits _ bitand ] bi ] ; inline
  15
  16 PRIVATE>
  17
  18 : each-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ) -- ... )
  19     permutation-bits-quot while drop ; inline
  20
  21 : map-permutation-bits ( ... bit-count bits quot: ( ... n -- ... m ) -- ... seq )
  22     permutation-bits-quot [ swap ] compose produce nip ; inline
  23
  24 : filter-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ? ) -- ... seq )
  25     selector [ each-permutation-bits ] dip ; inline
  26
  27 : all-permutation-bits ( bit-count bits -- seq )
  28     [ ] map-permutation-bits ;
  29
  30 : find-permutation-bits ( ... bit-count bits quot: ( ... n -- ... ? ) -- ... elt/f )
  31     [ f f ] 3dip [ 2nip ] prepose [ keep swap ] curry
  32     permutation-bits-quot [ [ pick not and ] compose ] dip
  33     while drop swap and ; inline
  34
  35 : reduce-permutation-bits ( ... bit-count bits identity quot: ( ... prev elt -- ... next ) -- ... result )
  36     -rotd each-permutation-bits ; inline