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 ...
23
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}
22
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 ...
19
Combinatorica` has the function NextPermutation which allows you to iterate over the permutations. There may be ways of generating a smaller subset if you have more information about what you are looking for.
19
Did I understand correctly?
Subsets[Range[1, 16], {2}]
EDIT: If you want to use Permutations, you could use
DeleteDuplicates[Permutations[Range[16], {2}], Sort[#1] == Sort[#2] &]
which deletes all "duplicates", where "duplicate" is defined by the equality of the two lists when sorted (ie, {2,3} is "equal" to {3,2} for purposes of this comparison).
...
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}
*)
17
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] := ...
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}
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
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 ...
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 ...
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 ...
13
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 ...
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
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
My interpretation of your question is: What cycles describe the permutation from order1 to order2?
order1 = {"G", "O", "V", "Y", "C", "H", "P", "W", "I", "Q", "X", "J", "D", "K", "R", "Z", "L", "M", "S", "N", "A", "E", "T", "B", "F", "U"};
order2 = {"G", "P", "L", "Y", "X", "I", "S", "R", "H", "D", "C", "B", "M", "O", "N", "K", "Q", "F", "A", "Z", "T", "U", ...
11
You could try this as an alternative:
Sort /@ Permutations[Range@16, {2}] // Union
11
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 ...
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"
, {"...
10
This will generate all of them, just like Tuples. Not too hard to redo so as to get one at a time. Just use the correspondence between k-digit numbers base n (n=length of input set) and subsets length k allowing repetitions.
takeWithRepitions[set_, k_] :=
Module[{n = Length[set], rule, vals},
rule = Thread[(Range[n] - 1) -> set];
vals = Map[...
10
A slightly different approach with Reduce (or Solve)
We define:
matC = Range[5]; (* the list of the integers from which we build a list *)
Let us use a vector to indicate the multiplicities of any integer:
matX = Array[ x, 5 ]; (* @Kuba: that's more concise, indeed *)
So x[1] will tell us how many times $1$ appears a possible solution.
We can then get ...
10
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, ...
Only top voted, non community-wiki answers of a minimum length are eligible
