29
How about a Monte-Carlo-Metropolis search? I'll implement a simplistic version here. See complete universal code further down. Update: Cleaned-up code now available in the Wolfram Function Repository, so you can use ResourceFunction["MaximizeOverPermutations"] instead of a locally-defined MaximizeOverPermutations. NUG25 and NUG30 are given as applications in ...
27
Chunks of derangements
Since I've already written library link code generating permutations, generating derangements requires just few tweaks:
/* derangements.c */
#include "WolframLibrary.h"
DLLEXPORT mint WolframLibrary_getVersion() {
return WolframLibraryVersion;
}
DLLEXPORT int WolframLibrary_initialize(WolframLibraryData libData) {
return ...
25
Since Mathematica 8 it is possible generate the elements of any group one by one with GroupElements. Here's for example a randomly chosen element of the permutation group on 20 elements:
GroupElements[SymmetricGroup[20], {10^6 + 1}]
{Cycles[{{11, 13, 19}, {12, 18, 17, 16}, {15, 20}}]}
The result is immediately; there's no need to build up the full group ...
24
This is the fastest method I have come up with:
s = Range @ 9;
Pick[#, Unitize[Times @@ (#\[Transpose] - s)], 1] & @ Permutations[s] //
Length // RepeatedTiming
{0.0408, 133496}
18
f[sum_, quant_] :=
Flatten[Permutations /@ IntegerPartitions[sum, {quant}, Range[0, sum]], 1]
f[3, 3] // Column
(*
{3,0,0}
{0,3,0}
{0,0,3}
{2,1,0}
{2,0,1}
{1,2,0}
{1,0,2}
{0,2,1}
{0,1,2}
{1,1,1}
*)
f[4, 2] // Column
(*
{4,0}
{0,4}
{3,1}
{1,3}
{2,2}
*)
18
Here is one way to generate them directly: it is based on a way to generate all permutations but discards invalid ones early:
derangements[{}, ___] = {{}};
derangements[list_List, orig_List] :=
Union @@
(Prepend[#] /@ derangements[DeleteCases[list, #, 1, 1], Rest@orig] &) /@
DeleteCases[list, First@orig]
derangements[list_List] := ...
18
A high-performance solution
Since you are planning to work with thousands of necklaces, it may be much faster to introduce a canonical form.
The main point is to write a necklace canonization function, which for all equivalent necklaces should return exactly the same result (canonical form). You can then apply canonization function to all necklaces in your ...
17
StringReplaceList
I just realized that there is a comparatively clean though not highly efficient way to write this using StringReplaceList:
op = Union @@ StringReplaceList[#, {"[]" -> "[[]]", "[]" -> "[][]"}] &;
Nest[op, {"[]"}, 3] // Column
[[[[]]]]
[[[][]]]
[[[]][]]
[[[]]][]
[[][[]]]
[[][][]]
[[][]][]
[[]][[]]
[[]][][]
[][[[]]]
[][[][]]
[][[]...
17
How about:
Module[{tmp = test},
With[{ord=Ordering[tmp]},
tmp[[ord]] = Reverse @ tmp[[ord]]];
tmp
]
{56, 9, 4, 3, -5, -2, -3, 1, 2, 7, 60, 58, 8, -4, 10, 6, 59, 5, 57, -1}
17
StringMatchQ["aabbc", "*a*c*"]
True
StringMatchQ["aabbc", "*b*a*"]
False
You can also use LongestCommonSequence to construct a function
ClearAll[strngCntnsQ]
strngCntnsQ = LongestCommonSequence[##] == #2 &;
strngCntnsQ["aabbc", "ac"]
True
strngCntnsQ["aabbc", "ba"]
False
16
Select[
IntegerPartitions[24, {8}, Range[5]],
#.# == 86 &
]
{{5, 5, 4, 2, 2, 2, 2, 2}, {5, 5, 3, 3, 3, 2, 2, 1},
{5, 4, 4, 4, 2, 2, 2, 1}, {5, 4, 4, 3, 3, 3, 1, 1}, {4, 4, 4, 4, 4, 2, 1, 1}}
Slightly more general approach (in case where IntegerPartitions is not what we need):
ClearAll[ar, a];
ar = Array[a, 8]
ar /. Solve[Flatten@{
Tr[ar] == ...
16
No, Ordering[Ordering[list]] not optimal. And yes, there is a faster method:
list = RandomReal[{-1, 1}, 1000000];
First@RepeatedTiming[
a[[Ordering[list]]] = a = Range[Length[list]];
]
First@RepeatedTiming[
b = Ordering[Ordering[list]]
]
a == b
0.13
0.236
True
Edit
J.M.'s second suggestion is more concise and at least as fast if not slightly ...
15
Assuming that your lists contain no duplicates you can use this:
set =
{{a, b, c, d}, {a, b, d, c}, {a, c, b, d}, {a, c, d, b}, {a, d, b, c},
{a, d, c, b}, {b, a, c, d}, {b, a, d, c}, {b, c, a, d}, {b, c, d, a},
{b, d, a, c}, {b, d, c, a}, {c, a, b, d}, {c, a, d, b}, {c, b, a, d},
{c, b, d, a}, {c, d, a, b}, {c, d, b, a}, {d, a, b, c}, {d, a, c, b},
...
15
I would use
a = Alphabet[]; (* letter *)
d = Range[0, 9]; (* digit *)
result = Tuples[{a, a, d, d, d, d}];
14
Is it any permutation ? Then I think then this should do
areListsEqual[List1_,List2_]:=(Sort[List1]===Sort[List2]);
14
The permutation you described is called "derangement". There is a function Derangement in Combinatoricapackage.
Needs["Combinatorica`"]
dearr = Select[list, OddQ][[#]] & /@ Derangements[Range[6]];
pos = Flatten@Position[list, _?OddQ];
res = ReplacePart[list, Thread[pos -> #]] & /@ dearr
res
(*{{5, 6, 3, 23, 21, 76, 77, 28, 96, 54, 1},
{5, 6, ...
14
Permutations where no element remains in its original place are called derangements. Counting them is easy enough: the number of derangements of a set of size $n$ is $!n$, or the subfactorial of $n$. Of course, that's a built-in in Mathematica:
list = {3,6,5,21,23,76,1,28,96,54,77};
Subfactorial @ Count[list, _?OddQ]
(* 265 *)
Generating them is a bit ...
14
Is this what you need?
StringContainsQ["aabbc","a" ~~ ___ ~~ "c"]
True
The following documentation pages should help you get going with string patterns in Wolfram Language:
https://reference.wolfram.com/language/tutorial/StringPatterns.html
https://reference.wolfram.com/language/tutorial/WorkingWithStringPatternsOverview.html
edit
Here is a function ...
13
Just a note - any method generating the permutations and the searching will get very slow very quickly, and blow RAM soon after.
Something like this s/b much more efficient (e.g., on my goof-top, for permutations of length 10, it's ~30,000X faster :
pr[{}] = 1;
pr[{x_, y___}] := Tr[Clip[{y}, {x, x - 1}, {1, 0}] ] Length@{y}! + pr[{y}];
13
Preface
If one could create a function f that calculates a canonical form of a necklace that turns all equivalent necklaces {t1, t2, ...} into one unique form t the solution is simple: Take your input list, create the canonical form of each item and delete all duplicates. If the function f is fast, then this approach should be the way to go.
As shown in ...
12
If I'm not mistaken, we can do this in closed form. Suppose we have $n$ indices split up into $n_1$ one-index variables, $n_2$ two-index variables, etc. Then the total number of distinct permutations is just $N=\dfrac{n!}{\prod\limits_{i}n_i!(i!)^{n_i}}$.
This accounts for the $n_i!$ permutations of $i$-index variables and the $i!$ permutations of each of ...
12
If you have many duplicates (and the number of duplicates matter) then Tally can improve performance sufficiently
orderlessSameQ[a_List, b_List] := (Length@a == Length@b) && (Sort@Tally@a === Sort@Tally@b);
a = RandomInteger[{0, 1000}, 1000000];
b = RandomSample[a];
areListsEqual[a, b] // AbsoluteTiming (* lalmei *)
orderlessSameQ[a, b] // ...
12
A simple recursive function I've used many times:
permutation[{e_}, _] := {e}
permutation[l_, n_] :=
With[{m = (Length[l] - 1)!},
permutation[Delete[l, Ceiling[n/m]], Mod[n, m, 1]]~Prepend~
l[[Ceiling[n/m]]]]
Note that this function assumes that n is a valid permutation number and that all elements are unique.
Update
Here is a solution that meets ...
12
Apparently, you try to apply a permutation given by list indirection to a vector duplicate.
Here are several ways to do it, each along with its timing:
n = 1000000;
indirection = RandomSample[Range[n], n];
duplicate = RandomInteger[{-n, n}, n];
First@RepeatedTiming[
result0 = createDupInvIndir[indirection, duplicate];
]
First@RepeatedTiming[
...
11
Subsets[Reverse@Range[5], {3}]
{{5, 4, 3}, {5, 4, 2}, {5, 4, 1}, {5, 3, 2}, {5, 3, 1}, {5, 2, 1},
{4, 3, 2}, {4, 3, 1}, {4, 2, 1}, {3, 2, 1}}
Reverse /@ Subsets[Range[5], {3}]
{{3, 2, 1}, {4, 2, 1}, {5, 2, 1}, {4, 3, 1}, {5, 3, 1}, {5, 4, 1},
{4, 3, 2}, {5, 3, 2}, {5, 4, 2}, {5, 4, 3}}
11
Getting the graph from the XYZ file
You have only a set of coordinates and atom types in an XYZ file. When you import it in Mathematica you can import 3 elements: the 3D plot, the coordinates, and atom types
{plot, coords, atoms} =
Import["https://raw.githubusercontent.com/nutjunkie/IQmol/master/share/fragments/Molecules/Amino_Acids/L-Cysteine.xyz"
, {"...
11
Here is a straightforward compiled implementation of Knuth's "Algorithm X" for lexicographically generating restricted permutations, specialized to the derangement case:
derange = Compile[{{list, _Integer, 1}},
Module[{n = Length[list], a, db, k, l, p, q, t, u},
a = Range[n]; l = Append[a, 0];
...
11
ClearAll[f]
f = DeleteDuplicates[#, MemberQ[Join @@ NestList[RotateLeft /@ # &,
{#, Reverse @ #}, Length@#], #2] &] &;
list = {{1, 1, 2, 1, 1, 2}, {1, 2, 1, 1, 2, 1}, {1, 2, 2, 1, 2, 2},
{1, 2, 2, 2, 1, 3}, {1, 2, 3, 1, 2, 3}, {1, 3, 1, 2, 2, 2},
{1, 3, 2, 1, 3, 2}, {2, 2, 1, 2, 2, 1}, {2, 2, 1, 3, 1, 2},
{2, 2, 2, 1, 3, 1}, {2, ...
11
mat = {Sort @ #, #} & @ PermutationList[a];
MatrixForm @ mat // TeXForm
$ \left(
\begin{array}{ccccccccccc}
1 & 2 & 3 & 4 & 5 & 6 & 7 & 8 & 9 & 10 & 11 \\
9 & 11 & 7 & 8 & 10 & 2 & 1 & 5 & 3 & 4 & 6 \\
\end{array}
\right)$
11
Total[Tuples@rn, {2}]
should do.
For cases where a very large number of tuples would be generated,
Fold[Total[Tuples[{##}], {2}] &, rn]
will generally be even quicker, and exhibit considerably lower memory pressure, to the point that it can be an order of magnitude faster because it can avoid paging if RAM gets low. If the ordering of the output is not ...
Only top voted, non community-wiki answers of a minimum length are eligible
