A lot of times, we don't necessarily need all the permutations, the real purpose is to select a part of interest according to condition. I wrote a function selectPermutations
, it's quite efficient and take up very little memory, sometimes would be useful.
ClearAll[selectPermutations];
Options[selectPermutations]={CompilationTarget->"WVM"};
selectPermutations[nn_Integer,cond_,A_List,OptionsPattern[]]:=
Module[{F,var,mm,iter,cTarget,cTime,cf,ans},
F=Symbol@*FromLetterNumber;
var=Variables[A];
mm=Length[var];
iter=Table[{F[ii+1],If[Select[cond&&Unequal@@var//Not//LogicalExpand,
F[ii]==Last@Sort@Cases[#,_Symbol,-1]&],0,Evaluate@If[ii<mm,nn,1]]},{ii,mm}];
cTarget=OptionValue[CompilationTarget];
cTime=First@AbsoluteTiming[
cf=Compile[{{a,_Integer}},
Module[{B=Internal`Bag[Rest@{0}]},
Do[Internal`StuffBag[B,#,1],##2];Internal`BagPart[B,All]],
RuntimeAttributes->{Listable},RuntimeOptions->"Speed",CompilationTarget->cTarget
]&[A,Sequence@@iter]];
If[cTarget=="C",Print["Compilation time: ",cTime]];
Print["Executing time: ",First@AbsoluteTiming[
ans=ArrayReshape[#,{Length[Flatten@#]/#2,#2}]&[cf[Range[nn]],Length[A]]]];
ans
]
Performance testing
I am using Mathematica 12 on a laptop running Windows 10 (64-bit), CPU: Intel i7-9750H, RAM: 32GB.
Case 1
Want to compute the permutations of {1, 2, ..., 11} with only 3 GB of memory
cond = And @@ (Abs[#-#2]!=1& @@@ {{a,b},{a,c},{b,c},{b,f},{b,e},{c,e},{c,f},{c,g},{d,f},
{d,g},{e,b},{e,a},{e,f},{e,i},{e,h},{f,g},{f,j},{f,i},{f,h},{g,i},{g,j},{h,i},{h,k},{i,j},
{i,k},{j,k}});
selectPermutations[11,cond,{a,b,c,d,e,f,g,h,i,j,k}]//Length
Output:
Executing time: 0.0915339
23632
Using Select
and Permutations
(*cond=Replace[cond, x_Symbol :> Indexed[#, LetterNumber@ToString@x], -1]*)
cf = With[{cond=cond},
Compile[{},
Select[Permutations[Range[11]],
Block[{a=#[[1]],b=#[[2]],c=#[[3]],d=#[[4]],e=#[[5]],f=#[[6]],g=#[[7]],h=#[[8]],i=#[[9]],
j=#[[10]],k=#[[11]]}, cond]&],
CompilationTarget->"C",RuntimeOptions->"Speed"
]
];
cf[]//Length//AbsoluteTiming
Output:
{4.29387, 23632}
Case 2
https://brg.a2hosted.com/?page_id=5489
Just a casual example. Actually, this program can be optimized, you can solve a diophantine equation first, and then traverse the 7 variables, this is not the point.
cond = (a+c+i==g+j+l&&a+h+l==g+i+k&&b+i+j==c+f+g&&b+d+i==e+g+h&&d+f+l==e+g+k)&&
(a+c+i<a+h+l<b+i+j<b+d+i<d+f+l);
selectPermutations[12,cond,{a,b,c,d,e,f,g,h,i,j,k,l},CompilationTarget->"C"]
Output:
Compilation time: 0.36566
Executing time: 0.340409
{{4, 8, 5, 9, 12, 11, 1, 6, 2, 7, 10, 3}}
Using Select
and Permutations
cf = With[{cond=cond},
Compile[{},
Select[Permutations[Range[12]],
Block[{a=#[[1]],b=#[[2]],c=#[[3]],d=#[[4]],e=#[[5]],f=#[[6]],g=#[[7]],h=#[[8]],i=#[[9]],
j=#[[10]],k=#[[11]],l=#[[12]]},cond]&],
CompilationTarget->"C",RuntimeOptions->"Speed"
]
];
cf[]//AbsoluteTiming
Ouput:
{412.059, {{4, 8, 5, 9, 12, 11, 1, 6, 2, 7, 10, 3}}}
1211 times faster.
Case 3
Magic hexagon
The task is to place the integers 1,...,19 in the following grid so that the sum of all numbers in a straight line (there are lines of length 3, 4 and 5) is equal.
Easy to prove, the magic constant is 38. First we can solve following equations, then traverse the 7 variables.
Solve[{x1+x2+x3==x4+x5+x6+x7==x8+x9+x10+x11+x12==x13+x14+x15+x16==x17+x18+x19==x1+x4+x8==
x2+x5+x9+x13==x3+x6+x10+x14+x17==x7+x11+x15+x18==x12+x16+x19==x3+x7+x12==x2+x6+x11+x16==
x1+x5+x10+x15+x19==x4+x9+x14+x18==x8+x13+x17==38},Array[Symbol["x"<>ToString@#] &, 19],
Integers,GeneratedParameters->Symbol@*FromLetterNumber][[1]]//Normal//Column
Output
x1->a
x2->b
x3->38-a-b
x4->c
x5->d
x6->e
x7->38-c-d-e
x8->38-a-c
x9->f
x10->g
x11->38-b-d-e-f-g
x12->-38+a+b+c+d+e
x13->38-b-d-f
x14->38-c-d-e-f-g
x15->-38+b+c+d+e+f
x16->d+f+g
x17->-38+a+b+c+d+f
x18->d+e+g
x19->76-a-b-c-2 d-e-f-g
A={a,b,38-a-b,c,d,e,38-c-d-e,38-a-c,f,g,38-b-d-e-f-g,-38+a+b+c+d+e,38-b-d-f,
38-c-d-e-f-g,-38+b+c+d+e+f,d+f+g,-38+a+b+c+d+f,d+e+g,76-a-b-c-2 d-e-f-g};
cond=LogicalExpand[Unequal@@A]&&And@@Thread[1<=Complement[A,Variables[A]]<=19];
selectPermutations[19,cond,A,CompilationTarget->"C"]
Output:
Compilation time: 0.656829
Executing time: 0.0106396
{{3, 17, 18, 19, 7, 1, 11, 16, 2, 5, 6, 9, 12, 4, 8, 14, 10,13, 15},
{3, 19, 16, 17, 7, 2, 12, 18, 1, 5, 4, 10, 11, 6, 8, 13, 9, 14, 15},
{9, 11, 18, 14, 6, 1, 17, 15, 8, 5, 7, 3, 13, 4, 2, 19, 10, 12, 16},
{9, 14, 15, 11, 6, 8, 13, 18, 1, 5, 4, 10, 17, 7, 2, 12, 3, 19, 16},
{10, 12, 16, 13, 4, 2, 19, 15, 8, 5, 7, 3, 14, 6, 1, 17, 9, 11, 18},
{10, 13, 15, 12, 4, 8, 14, 16, 2, 5, 6, 9, 19, 7, 1, 11, 3, 17, 18},
{15, 13, 10, 14, 8, 4, 12, 9, 6, 5, 2, 16, 11, 1, 7, 19, 18, 17, 3},
{15, 14, 9, 13, 8, 6, 11, 10, 4, 5, 1, 18, 12, 2, 7, 17, 16, 19, 3},
{16, 12, 10, 19, 2, 4, 13, 3, 7, 5, 8, 15, 17, 1, 6, 14, 18, 11, 9},
{16, 19, 3, 12, 2, 7, 17, 10, 4, 5, 1, 18, 13, 8, 6, 11, 15, 14, 9},
{18, 11, 9, 17, 1, 6, 14, 3, 7, 5, 8, 15, 19, 2, 4, 13, 16, 12, 10},
{18, 17, 3, 11, 1, 7, 19, 9, 6, 5, 2, 16, 14, 8, 4, 12, 15, 13, 10}}
Using Select
and Permutations
cf = With[{cond=cond},
Compile[{{v,_Integer,2}},
Select[v,Block[{a=#[[1]],b=#[[2]],c=#[[3]],d=#[[4]],e=#[[5]],f=#[[6]],g=#[[7]]},cond]&],
CompilationTarget->"C",RuntimeOptions->"Speed"
]
];
Function[{a,b,c,d,e,f,g},Evaluate@A] @@@ cf[Permutations[Range[19],{7}]]//AbsoluteTiming
Output:
{27.3219, {{3, 17, 18, 19, 7, 1, 11, 16, 2, 5, 6, 9, 12, 4, 8, 14, 10,13, 15},
{3, 19, 16, 17, 7, 2, 12, 18, 1, 5, 4, 10, 11, 6, 8, 13, 9, 14, 15},
{9, 11, 18, 14, 6, 1, 17, 15, 8, 5, 7, 3, 13, 4, 2, 19, 10, 12, 16},
{9, 14, 15, 11, 6, 8, 13, 18, 1, 5, 4, 10, 17, 7, 2, 12, 3, 19, 16},
{10, 12, 16, 13, 4, 2, 19, 15, 8, 5, 7, 3, 14, 6, 1, 17, 9, 11, 18},
{10, 13, 15, 12, 4, 8, 14, 16, 2, 5, 6, 9, 19, 7, 1, 11, 3, 17, 18},
{15, 13, 10, 14, 8, 4, 12, 9, 6, 5, 2, 16, 11, 1, 7, 19, 18, 17, 3},
{15, 14, 9, 13, 8, 6, 11, 10, 4, 5, 1, 18, 12, 2, 7, 17, 16, 19, 3},
{16, 12, 10, 19, 2, 4, 13, 3, 7, 5, 8, 15, 17, 1, 6, 14, 18, 11, 9},
{16, 19, 3, 12, 2, 7, 17, 10, 4, 5, 1, 18, 13, 8, 6, 11, 15, 14, 9},
{18, 11, 9, 17, 1, 6, 14, 3, 7, 5, 8, 15, 19, 2, 4, 13, 16, 12, 10},
{18, 17, 3, 11, 1, 7, 19, 9, 6, 5, 2, 16, 14, 8, 4, 12, 15, 13, 10}}}
2570 times faster.
Related link: Using Meta programming + Compile to speed up Backtracking algorithm
2^31-1
. This is a huge array: a2^31 - 1
-element packed array of machine integers (i.e. assuming the most efficient storage possible) would take up 8 GB of contiguous memory. You need to have a lot of memory in your computer to be able to store such an array (definitely much more than 8 GB because of the contiguous memory block requirement) $\endgroup$