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, ...
39
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.
...
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, ...
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
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 ...
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{...
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 ...
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
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 ...
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
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.
...
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
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
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,8341 gold badge14 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
These things I have coded up before Mathematica 7 and the introduction of the built in function LongestCommonSubsequence. The built-in version is of course faster, though still this implementation might be of interest as it has a bit wider functionality. Also, with some fine-tuning and compilation the performance can be surely increased.
...
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}
Only top voted, non community-wiki answers of a minimum length are eligible
