1 ! Copyright (c) 2007-2010 Slava Pestov, Doug Coleman, Aaron Schaefer, John Benediktsson.
2 ! See http://factorcode.org/license.txt for BSD license.
4 USING: accessors arrays assocs binary-search fry kernel locals
5 math math.order math.ranges namespaces sequences sorting ;
11 : possible? ( n m -- ? )
12 0 rot between? ; inline
14 : twiddle ( n k -- n k )
15 2dup - dupd > [ dupd - ] when ; inline
19 : factorial ( n -- n! )
20 iota 1 [ 1 + * ] reduce ;
23 2dup possible? [ dupd - [a,b) product ] [ 2drop 0 ] if ;
26 twiddle [ nPk ] keep factorial / ;
29 ! Factoradic-based permutation methodology
33 : factoradic ( n -- factoradic )
34 0 [ over 0 > ] [ 1 + [ /mod ] keep swap ] produce reverse 2nip ;
36 : (>permutation) ( seq n -- seq )
37 [ '[ _ dupd >= [ 1 + ] when ] map ] keep prefix ;
39 : >permutation ( factoradic -- permutation )
40 reverse 1 cut [ (>permutation) ] each ;
42 : permutation-indices ( n seq -- permutation )
43 length [ factoradic ] dip 0 pad-head >permutation ;
47 : permutation ( n seq -- seq' )
48 [ permutation-indices ] keep nths ;
50 : all-permutations ( seq -- seq' )
51 [ length factorial iota ] keep
52 '[ _ permutation ] map ;
54 : each-permutation ( seq quot -- )
55 [ [ length factorial iota ] keep ] dip
56 '[ _ permutation @ ] each ; inline
58 : reduce-permutations ( seq identity quot -- result )
59 swapd each-permutation ; inline
61 : inverse-permutation ( seq -- permutation )
62 <enum> sort-values keys ;
65 ! Combinadic-based combination methodology
75 : choose ( combo -- nCk )
76 [ seq>> length ] [ k>> ] bi nCk ;
78 : largest-value ( a b x -- v )
82 [ iota ] 2dip '[ _ nCk _ >=< ] search nip
85 :: next-values ( a b x -- a' b' x' v )
86 a b x largest-value dup :> v ! a'
91 : dual-index ( m combo -- m' )
94 : initial-values ( combo m -- n k m )
95 [ [ seq>> length ] [ k>> ] bi ] dip ;
97 : combinadic ( combo m -- combinadic )
98 initial-values [ over 0 > ] [ next-values ] produce
101 :: combination-indices ( m combo -- seq )
102 combo m combo dual-index combinadic
103 combo seq>> length 1 - swap [ - ] with map ;
105 : apply-combination ( m combo -- seq )
106 [ combination-indices ] keep seq>> nths ;
108 : combinations-quot ( seq k quot -- seq quot )
109 [ <combo> [ choose iota ] keep ] dip
110 '[ _ apply-combination @ ] ; inline
114 : each-combination ( seq k quot -- )
115 combinations-quot each ; inline
117 : map-combinations ( seq k quot -- )
118 combinations-quot map ; inline
120 : map>assoc-combinations ( seq k quot exemplar -- )
121 [ combinations-quot ] dip map>assoc ; inline
123 : combination ( m seq k -- seq' )
124 <combo> apply-combination ;
126 : all-combinations ( seq k -- seq' )
127 [ ] combinations-quot map ;
129 : reduce-combinations ( seq k identity quot -- result )
130 [ -rot ] dip each-combination ; inline
132 : all-subsets ( seq -- subsets )
133 dup length [0,b] [ all-combinations ] with map concat ;
137 : (selections) ( seq n -- selections )
138 [ [ 1array ] map dup ] [ 1 - ] bi* [
139 cartesian-product concat [ { } concat-as ] map
144 : selections ( seq n -- selections )
145 dup 0 > [ (selections) ] [ 2drop { } ] if ;