30
Chunks of weak compositions
Here is slightly modified version of algorithm used in Combinatorica`NextComposition converted to a LibraryFunction.
Needs["CCompilerDriver`"]
"
#include \"WolframLibrary.h\"
DLLEXPORT mint WolframLibrary_getVersion() {
return WolframLibraryVersion;
}
DLLEXPORT int WolframLibrary_initialize(WolframLibraryData libData) {
...
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
Recursion
This is top-level code and therefore unlikely to be as efficient as a compiled solution, but the recursive algorithm should have reasonable computational complexity:
f[u : {a_, x___}, v : {b_, y___}, c___] := f[{x}, v, c, a] ~Join~ f[u, {y}, c, b]
f[{x___}, {y___}, c___] := {{c, x, y}} (* rule for empty-set termination *)
Now:
f[{a, b}, {c, d}]
...
answered Feb 3 '14 at 10:28
Mr.Wizard
259k3333 gold badges540540 silver badges12171217 bronze badges
24
Here we go...
highlightString[board_, str_] := With[{l = Characters[str]},
board // horizontal[l] // vertical[l] // diagonal[l] // diagonalReversed[l]]
horizontal[letters_][board_] := applyStyle[letters] /@ board
vertical[letters_][board_] := Transpose[applyStyle[letters] /@ Transpose[board]]
diagonal[letters_][board_] := diagonalD[applyStyle[letters] /@ ...
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}
answered Mar 23 '17 at 4:14
Mr.Wizard
259k3333 gold badges540540 silver badges12171217 bronze badges
20
Subsets function takes optional third argument with standard sequence specification. Using this third argument you can take subsets "in chunks".
For example, following code gives three 5-combinations from positions 90000 to 90002, from all 8 trillions 5-combinations of set of 1000 elements:
Subsets[Range[1000], {5}, {90000, 90002}]
(* {{1, 2, 3, 98, 845}, {...
20
This is of course the Chinese postman problem, which is solved by the function FindPostmanTour[]. First, represent the edges of the directed graph:
edges = {1 -> 2, 1 -> 3, 2 -> 4, 3 -> 2, 3 -> 4, 4 -> 1, 4 -> 5, 5 -> 3};
house = Graph[edges,
VertexCoordinates -> {{0, 0}, {1, 0}, {1, 1}, {0, 1}, {1/2, 1 + Sqrt[3]/2}}...
answered Oct 15 '16 at 2:01
20
Here is a piece of code that is inspired by quantum field theory. The physics background can be found in this physics.SE post.
First, we define some auxiliary functions:
ClearAll[Δ, corr, reduce, allgraphs]
SetAttributes[Δ, Orderless];
corr[{a_, b_}] := Δ[a, b];
corr[{a_, b__}] := corr[{a, b}] =
Sum[
corr[{a, List[b]...
answered Apr 2 '18 at 15:56
AccidentalFourierTransform
9,04211 gold badge1515 silver badges4848 bronze badges
20
ClearAll[step, bishopsPath]
step[{nc_, nr_}][{start : {_, _}, {_, _}}] := {Total @ #, Last[{Total @ #, #[[2]]} /.
{{t : start | {1 | nc, 1 | nr}, _} :> {t, {0, 0}},
{t : {_, nr} | {_, 1}, d_} :> {t, {1, -1} d},
{t : {1, _} | {nc, _}, d_} :> {t, {-1, 1} d}}]} &;
bishopsPath[{nc_, nr_}][arg : Alternatives[{{1, _}, {-1, _}},
{{_,...
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}
*)
answered Mar 10 '13 at 23:32
Dr. belisarius
113k1212 gold badges187187 silver badges430430 bronze badges
18
I propose a more compact approach
f[list__] := Join @@ ReplaceList[{list}, {x__, y__} :> Tuples@{f[x], f[y]}]
f[x_] := {x};
f[a, b, c, d] // Column
{a,{b,{c,d}}}
{a,{{b,c},d}}
{{a,b},{c,d}}
{{a,{b,c}},d}
{{{a,b},c},d}
One can note that the length of this list is the Catalan number
$$
C_n = \frac{1}{1+n}{2n\choose n}
$$
Length[f @@ ConstantArray[a, 6]...
18
Here is a summary of comments (before @ciao's best answer above), with a change in notation. These functions calculate the number of partitions of n into exactly k distinct parts of size at most m.
NumberOfWays000[n_, k_, m_] :=
Count[Map[Length,Map[DeleteDuplicates, IntegerPartitions[n,{k},Range[m]]]], k]
NumberOfWays001[n_, k_, m_] :=
Total[Boole[...
18
This seems pretty quick, particularly on larger cases / larger k, e.g.
451, 29, 101 finishes in a few seconds on the loungebook.
N.B. - I have not tested this exhaustively, just thrown together from ideas...
If[Min[#3, #1 - Tr@Range@(#2 - 1)] < 0, 0,
SeriesCoefficient[QPochhammer[-x y, x, Min[#3, #1 - Tr@Range@(#2 - 1)]],
{x , ...
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] := ...
17
I don't think there is a carpet graph built-in, but it's hard to be sure that something is not there. Still it's not hard to construct a Graph -- not quite the same thing as drawing it (I wasn't sure what you meant).
There are probably more efficient ways, but adapting Mr.Wizard's carpet function, it is fairly straightforward to make an edge between ...
answered Aug 19 '13 at 14:58
Michael E2
191k1515 gold badges259259 silver badges601601 bronze badges
17
Here's my solution using pattern-matching:
Range[10] //. {x_, y_, z___} :> {z, x}
{5}
17
A solution using Repeated, ReplaceList, and the Orderless attribute.
part[a_List, p_List] :=
Module[{f, sym},
Attributes[f] = Orderless;
sym = Unique["x", Temporary] & /@ p;
ReplaceList[
f @@ a,
f @@ MapThread[Pattern[#, Repeated[_, {#2}]] &, {sym, p}] -> List /@ sym
]
]
part[{1, 2, 3, 4, 5}, {2, 2, 1}]
{{{1, 2}...
answered Aug 13 '16 at 15:00
Mr.Wizard
259k3333 gold badges540540 silver badges12171217 bronze badges
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
[[[[]]]]
[[[][]]]
[[[]][]]
[[[]]][]
[[][[]]]
[[][][]]
[[][]][]
[[]][[]]
[[]][][]
[][[[]]]
[][[][]]
[][[]...
answered Mar 27 '17 at 19:45
Mr.Wizard
259k3333 gold badges540540 silver badges12171217 bronze badges
16
Here is a totally different approach based on the fact that successive products forming the generating function are due to multiplication by a binomial $1+t*z^j$. Form a matrix $v$ of zeros with $n+1$ rows and $k+1$ columns. Initialize the top left corner to 1. Iterate $v=v+w$ where $w$ is the matrix $v$ shifted down by $j$ rows and to the right by 1. The ...
16
RandomPartition[n_, p_] :=
Module[{r},
r = RandomSample[Range[n - 1], p - 1] // Sort;
AppendTo[r, n];
Prepend[r // Differences, r[[1]]]
]
RandomPartition[100, 16]
(* {4, 1, 4, 3, 12, 5, 13, 3, 9, 8, 2, 2, 12, 11, 1, 10} *)
RandomPartition[100, 16] // Total
(* 100 *)
Testing:
And @@ Table[
n = RandomInteger[100000];
p = RandomInteger[{1, n}];...
answered Nov 1 '15 at 19:46
Sjoerd C. de Vries
63.5k1414 gold badges176176 silver badges311311 bronze badges
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
There is also a newer package, HolonomicFunctions, that has an implementation of Chyzak's generalization of Zeilberger's algorithm. To perform the desired task, use the following commands:
smnd = Simplify[
G /. HoldPattern[HypergeometricPFQ[pl_List, ql_List, x_]] :>
(Times @@ (Pochhammer[#, k] & /@ pl)) /
(Times @@ (Pochhammer[#, k] & /@ ql)...
15
Probably not too bad performance-wise, haven't tested though:
x = {a, b};
y = {c, d};
n = Length[x] + Length[y];
px = Subsets[Range[n], {Length[x]}];
py = Reverse[Subsets[Range[n], {Length[y]}]];
Normal /@ MapThread[SparseArray[{#1 -> x, #2 -> y}] &, {px, py}]
(* {{a, b, c, d}, {a, c, b, d}, {a, c, d, b}, {c, a, b, d}, {c, a, d, b}, {c, d, a, b}...
15
The implementation of lazy tuples here pretty much contains the solution to the lazy Outer problem. I will take the relevant parts from that code.
The following code constructs a function take, which would, given the start and end positions in the flat list of the resulting combinations, extract the elements:
ClearAll[next];
next[{left_, _}, dim_] :=
{...
answered Mar 10 '16 at 0:32
Leonid Shifrin
108k1414 gold badges311311 silver badges401401 bronze badges
15
Permutations treats repeated elements as identical, so you can get a flattened version of the desired result with something like
Ordering /@ Permutations[{1, 1, 2, 2, 3}]
(* {{1, 2, 3, 4, 5}, {1, 2, 3, 5, 4}, {1, 2, 4, 5, 3} ... {4, 5, 2, 3, 1} *)
A simple solution based on this idea:
parts[list_, p_] := Module[{q},
q = Flatten@MapThread[ConstantArray, ...
answered Aug 13 '16 at 21:31
Simon Woods
81.9k88 gold badges162162 silver badges310310 bronze badges
15
I would use
a = Alphabet[]; (* letter *)
d = Range[0, 9]; (* digit *)
result = Tuples[{a, a, d, d, d, d}];
answered Feb 20 '17 at 10:13
Szabolcs
213k2222 gold badges532532 silver badges11181118 bronze badges
14
Your explanations are very detailed and I have to admit it's too detailed for me to go through it, trying to understand without a minimal working example. Therefore, view this as some ideas for your first, short-version question. I will present two different approaches, where the first one takes very long, but consumes almost no memory and the second one is ...
14
NestWhile[Rest @ RotateLeft @ # &, Range @ 10, Length @ # > 1 &]
{5}
FixedPoint[If[Length @ # > 1, Rest @ RotateLeft[#], #] &, Range @ 10]
Edit
Historical note: As far as I can remember, Josephus roulette (a plain treason to his companions) consisted of killing every third person.
FixedPoint[If[Length@# != 1, Rest@RotateLeft[#, 2], #]...
answered Oct 7 '13 at 11:33
Dr. belisarius
113k1212 gold badges187187 silver badges430430 bronze badges
14
Something different, impractical yet amusing, with a hint of mathematical insouciance...
s1 = {a, b, c}
s2 = {f, g, h}
sall = Join[s1, s2];
ln = Length[sall];
s = Solve[
Max[sall] == ln && Min[sall] == 1 && Less[Sequence @@ s1] &&
Less[Sequence @@ s2] && Unequal[Sequence @@ sall], sall, Integers];
Range@ln /. MapAt[...
Only top voted, non community-wiki answers of a minimum length are eligible
Related Tags
combinatorics × 425list-manipulation × 103
graphs-and-networks × 65
permutation × 65
performance-tuning × 38
partitions × 35
matrix × 20
combinatorica × 18
programming × 17
summation × 15
algorithm × 14
functions × 13
function-construction × 13
probability-or-statistics × 13
group-theory × 13
number-theory × 10
sets × 10
equation-solving × 9
pattern-matching × 9
memory × 9
subset × 9
string-manipulation × 7
lazy-computations × 7
symbolic × 6
special-functions × 6