48
Preamble and motivation
While I am much late to the party here, I hope this answer will not be totally useless. This is a first in a series of posts where I will advocate a wider use of Java in our workflow, and present/describe certain toolset to reduce the mental overhead of this. So, my motivation here is not to provide a faster or more elegant solution, ...
38
The answer of @R.M. already explains the essence of the problem. You can streamline the process of removing the Combinatorica from the $ContextPath by loading it via
Block[{$ContextPath}, Needs["Combinatorica`"]]
(or use Get intead of Needs, although Needs is a preferred way to load a package). In this way, you don't have to do anything afterwards, since, ...
38
We are challenged to determine "how fast MMa can get" and, in so doing, to suggest rules "to choose different programming styles." The original solution takes 116 seconds (on my machine). At the time the question was posted, the solution time had been reduced by a factor of 1000 (10 doublings of speed) to 0.124 seconds by suggestions from users in chat.
...
33
Try with
partitions[list_, l_] := Join @@
Table[
{x, ##} & @@@ partitions[list ~Complement~ x, l],
{x, Subsets[list, {l}, Binomial[Length[list] - 1, l - 1]]}
]
partitions[list_, l_] /; Length[list] === l := {{list}}
The list must have a length multiple of l
30
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 ...
29
Shadowing occurs only when there are two functions with the same name that are in $ContextPath. So right after you do <<Combinatorica`, do the following:
$ContextPath = Rest@$ContextPath;
What this does is that it removes Combinatorica (which is the package you just loaded). Now the only Graph function that's on the path is System`Graph and you can ...
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{...
29
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) {
...
28
Mathematica supports two related functions, LongestCommonSequence[] and LongestCommonSubsequence[]. The first one finds the longest (contiguous or non-contiguous) sequence common to the two strings given as arguments to it:
LongestCommonSequence["AAABBBBCCCCC", "CCCBBBAAABABA"]
"AAABB"
while the second function is constrained to give the longest contiguous ...
answered May 28 '12 at 16:59
27
Here is an alternative version of Mr. Wizard's uniqueTuples function, which is faster on the data I have tested.
The idea is to create a function f which has the following properties:
It returns an empty Sequence[] if two of its arguments are the same
For any other input it outputs a List of the arguments, but also
sets a downvalue so that next time it is ...
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
The solution is straightforward: Subsets, specifically
Subsets[{1,2,3}, {2}]
gives
{{1, 2}, {1, 3}, {2, 3}}
To generate the lower indices, just Reverse them
Reverse /@ Subsets[{1,2,3}, {2}]
which gives
{{2, 1}, {3, 1}, {3, 2}}
23
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}...
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] /@ ...
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 ...
22
Here is one way:
ClearAll[f];
f[tree_List] := Flatten[f[{}, tree], 1];
f[accum_List, {x_, y_List}] := f[{accum, x}, #] & /@ y;
f[x_, y_] := Flatten[{x, y}];
The usage is
f[B]
22
A very simple and straightforward test for square-freeness (and should be reasonably fast) is:
squareFreeQ[str_] := StringFreeQ[str, x__ ~~ x__]
Testing on your inputs:
squareFreeQ["0101"]
(* False*)
squareFreeQ["0102012021"]
(* True *)
You can then possibly restrict this further to operate only on certain alphabets using Repeated and Alternatives.
...
21
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
Also, using pattern matching,just in case:
{{a, b, c, d, e, f, g}, {x, a, r, b, c, j}} /. {{___, Longest[y__], ___}, {___, y__, ___}} -> {y}
(*
-> {b, c}
*)
Edit
With this approach you can do one thing that seems not trivial by using the faster LongestCommonSequence[] function: finding the maximal common subsequence among several lists:
{{1, 2, 3, ...
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,1481 gold badge14 silver badges46 bronze badges
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
Copying my clock post? Impossible! Anyway,
Chapter one: using brute force.
Before you complain: I'm a physicist, this is how we do mathematics: by experiment. Ha!
We need cards! Inconveniently, Mathematica currently lacks built-in support for Kings. We therefore have to use a workaround: let's call the named cards by their numbers. A is 1, J is 11 etc. ...
19
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}, {...
18
Edit 2015
While I found Simon Woods's code informative to the degree that I awarded it a bounty it seems that the only reason it performed better than mine was that DeleteDuplicates was slow. Fred Simons pointed out that my (original) code is no longer slow, and actually outperforms Simon Woods' function. Experimentation showed that using Union in version ...
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[...
Only top voted, non community-wiki answers of a minimum length are eligible
