31
In a sense described below, this answer finds $422716$ distinct solutions.
The innovations presented here are
using postfix operators to eliminate problems with parentheses;
avoiding having to deal with unary negation;
initially computing "too many" solutions, some of which make no sense, and eliminating them at the end (rather than writing more ...
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) {
...
29
Letting $j_k = i_{k+1}-i_k-1$ and writing $$Q(n) = P(n) - P(n-1) = C\sum_{0 \le j_1, j_2, \cdots, j_{51}\vert j_1+\cdots+j_{51}=n-52} \prod_{k=1}^{51}\left(\frac{k}{52}\right)^{j_k}\,,$$ with $C$ a constant, exhibits the $P(n)$ as cumulative sums of the $Q(n)$ and shows that $Q(n)$ is the coefficient of $x^{n-52}$ in the formal power series
$$q(x) = \frac{...
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}]
...
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}
23
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] /@ ...
22
Let's replace 52 with $d$. Then we are seeking to compute
$$
p_d(n) = \frac{(d-1)!}{d^{d-1}} \sum_{1 = i_1 < i_2 < \cdots < i_{d-1} < i_{d} \leqslant n} \left[ \prod_{k=1}^{d-1} \left( \frac{k}{d} \right)^{i_{k+1}-i_k-1} \right] \tag{1}
$$
The set $\{i_2, \ldots,i_d\}$ is a length $d-1$ subset of natural consecutive numbers from 2 to $n$. The ...
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
8,9341 gold badge15 silver badges48 bronze badges
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
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
The following seems fast and less memory bound, because it's based on SatisfiabilityCount[], a wonderful function to count boolean valued functions with boolean arguments:
count[l : {_String ..}] := Module[{x, sp},
sp[s_String, sub_String] := StringPosition[s, sub][[All, 1]];
SatisfiabilityCount[
And @@ Not /@ (And @@@ (x /@ sp[#, "1"]...
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 ...
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}...
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
[[[[]]]]
[[[][]]]
[[[]][]]
[[[]]][]
[[][[]]]
[[][][]]
[[][]][]
[[]][[]]
[[]][][]
[][[[]]]
[][[][]]
[][[]...
16
EDIT: As @Rojo points out in the comments, my code doesn't really find all solutions. For example, a term of the form a * (b * c + d) can't be represented with "precedence plus/minus" operators. I'm not sure if it is salvageable, but as it is, the code below does not find all solutions.
A very simple solution would be to define two new operators $\oplus$ ...
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.1k12 gold badges173 silver badges310 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
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, ...
15
I would use
a = Alphabet[]; (* letter *)
d = Range[0, 9]; (* digit *)
result = Tuples[{a, a, d, d, d, d}];
Only top voted, non community-wiki answers of a minimum length are eligible
