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}]
...
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}
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}}...
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,1671 gold badge15 silver badges48 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, _}},
{{_,...
20
An example target, a bit over half-a-million digits:
x = 123456!;
IntegerLength@x
574965
Results for target, and a non-hit:
Reduce`FactorialInverse[x] // AbsoluteTiming
Reduce`FactorialInverse[x+1]
{0.0138732, {123456}}
{}
I do not suggest trying to compare this with the function suggested in the current comment: it never finishes / crashes my kernel (12....
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 ...
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
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}];...
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_] :=
{...
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}];
15
Stirling's approximation, $n! \sim n^ne^{-n}$, is the Swiss army knife of factorial problems. If $x = n!$, this implies that $\ln x \sim n \ln n - n$; and surprisingly this can be solved with a built-in special function:
Solve[n (Log[n] - 1) == Log[x], n]
(* {n -> Log[x]/ProductLog[Log[x]/E]} *)
So we calculate this number, look at nearby integers, ...
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], #]...
Only top voted, non community-wiki answers of a minimum length are eligible
