basis/math/combinatorics/combinatorics.factor

   1 ! Copyright (c) 2007, 2008 Slava Pestov, Doug Coleman, Aaron Schaefer.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs kernel math math.order math.ranges mirrors
   4 namespaces sequences sorting fry ;
   5 IN: math.combinatorics
   6
   7 <PRIVATE
   8
   9 : possible? ( n m -- ? )
  10     0 rot between? ; inline
  11
  12 : twiddle ( n k -- n k )
  13     2dup - dupd > [ dupd - ] when ; inline
  14
  15 ! See this article for explanation of the factoradic-based permutation methodology:
  16 ! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
  17
  18 : factoradic ( n -- factoradic )
  19     0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ;
  20
  21 : (>permutation) ( seq n -- seq )
  22     [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;
  23
  24 : >permutation ( factoradic -- permutation )
  25     reverse 1 cut [ (>permutation) ] each ;
  26
  27 : permutation-indices ( n seq -- permutation )
  28     length [ factoradic ] dip 0 pad-left >permutation ;
  29
  30 PRIVATE>
  31
  32 : factorial ( n -- n! )
  33     1 [ 1+ * ] reduce ;
  34
  35 : nPk ( n k -- nPk )
  36     2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
  37
  38 : nCk ( n k -- nCk )
  39     twiddle [ nPk ] keep factorial / ;
  40
  41 : permutation ( n seq -- seq )
  42     [ permutation-indices ] keep nths ;
  43
  44 : all-permutations ( seq -- seq )
  45     [ length factorial ] keep '[ _ permutation ] map ;
  46
  47 : each-permutation ( seq quot -- )
  48     [ [ length factorial ] keep ] dip
  49     '[ _ permutation @ ] each ; inline
  50
  51 : reduce-permutations ( seq initial quot -- result )
  52     swapd each-permutation ; inline
  53
  54 : inverse-permutation ( seq -- permutation )
  55     <enum> >alist sort-values keys ;