# Tag Info

34

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, ...

27

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) = ... 22 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, ... 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. ... 20 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 ...

19

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 ...

19

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}}

19

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 ...

16

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

16

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 SystemGraph and you can ... 15 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. ... 15 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 ... 14 Showing humongous data by screen-fulls can be done using Manipulateas follows: (* generate some data to show *) res = Tuples[{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}, 7]; (* size of the data*) ByteCount[res] (* ==> 1003290792 *) screenNumbers = 100; Manipulate[ Take[res, {i screenNumbers + 1, (i + 1) screenNumbers}], {i, 0, ... 14 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, ... 13 Just for the sake of functional programming here is a solution which is neither in speed nor memory comparable to Subsets but which only uses basic list operations and pattern matching: makePairs[{e_, es__}] := Join[{e, #} & /@ {es}, makePairs[{es}]]; makePairs[{e_}] := {}; It grabs the first element of the list and makes pairs with the other ... 13 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[#, ... 13 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$... 12 Take all subsets of length 10, then for each one find all splits into two sets of five such that the first of the ten is in the first part of the split. In[29]:= Timing[ msets = Subsets[Range[12], {10}]; m2 = Flatten[ Map[With[{fst = First[#], subs = Subsets[Rest[#], {4}], mset = #}, With[{s2 = Map[Join[{fst}, #] &, subs]}, Map[{#, ... 12 The Combinatorica package is now considered obsolete and not compatible with Mathematica's built-in Graph theory functionality. The function CycleGraph, which you are using, is a built-in function and is not understood by the Combinatorica package. You have to replace CycleGraph[i] simply by Cycle[i], which is the corresponding object in Combinatorica. You ... 12 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. ... 11 Ok, I'll stick to "making MMA do the thinking" The list of all the possibile hands a player can have playerPossibilities = Tuples[Range[13], {2}]; The list of all the triplets of hands the 3 players could have been handed allPossibilities = Tuples[playerPossibilities, {3}]; A function that returns True if a1 won a1winsQ[{h1 : {_, _}, h2_, h3_}] := # ... 11 Edit This one is much simpler than those I posted before . And very efficient Timing@StringFreeQ[benchmark, RegularExpression["(.+)\\1"]] Previous posts: Timings done on a VERY slow machine: Timing@Not@StringMatchQ[benchmark, RegularExpression[".*(.{1,1000})\\1(.*)"]] (* -> {0.735, True} *) Edit There is a problem if the repeated string has ... 11 If you need the ultimate speed, the following compiled code will be about 20 - 30 times faster than the elegant string-pattern based solution of @R.M. (but, of course, as many times longer and uglier): With[{part = CompileGetElement}, squareFreeQLSC = Compile[{{ll, _Integer, 1}}, Module[{res = 0, ctr = 1, sctr = 1, len = 0, start = 0, i = 0}, ... 10 This has [quadratic, he said] actually perhaps cubic complexity in a worst case (okay, now I'm just confused. More below).. Not the fastest of the lot, but it seems reasonable, or at least not entirely unreasonable. Requires some thought for me to see what I'm doing that keeps it relatively slow. squareFree[wrd_String] := squareFreeC[ToCharacterCode[wrd]] ... 10 If I'm not mistaken, we can do this in closed form. Suppose we have$n$indices split up into$n_1$one-index variables,$n_2$two-index variables, etc. Then the total number of distinct permutations is just$N=\dfrac{n!}{\prod\limits_{i}n_i!(i!)^{n_i}}$. This accounts for the$n_i!$permutations of$i$-index variables and the$i!\$ permutations of each of ...

10

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 ...

9

I believe this is correct. It is based on BellList from Robert M. Dickau. Module[{n = 4, q = 2, r, BellList}, r = n/q; BellList[1] = {{{1}}}; BellList[n_Integer?Positive] := Join @@ (ReplaceList[#, {{b___, {S : Repeated[_, {1, q - 1}]}, a___} :> {b, {S, n}, a}, {S : Repeated[_, {1, r - 1}]} :> {S, {n}}} ] & /@ ...

9

Here's a moderately parallelizable solution. It constructs the tuples sequentially so that, at the end, you can be assured the first element is from the first list, the second from the second, etc. newTuples[t_, x_] := Flatten[ ParallelTable[Append[s, #] & /@ Complement[x, s], {s, t}], 1]; Timing[ts = Fold[newTuples, {{}}, {a, b, c, d, e, f}];] ...

9

Here is a brute-force algorithm for four-letter word squares (not cubes) that takes about a second on a three-year-old laptop. findWordSquare[first_String] /; StringLength[first] == 4 := Module[{words = Select[DictionaryLookup[{"English", All}], StringLength[#] == 4 &], secondlist, thirdlist, f2 = StringTake[first, {2}], f3 = ...

9

Here you have a (rather inefficient) piece of code: l = {a, b, c, d}; r = ReplaceList[Range@Length@l, {a___, x_, y_, b___} -> {a, y, x, b}]; g = Quiet@Graph[ DeleteDuplicates@(Flatten[(UndirectedEdge[x, #] & /@ Function[t, Map[t[[#]] &, r, {2}]][x]) /. x -> # & /@ Permutations@l, 1] /. UndirectedEdge[x_, x_] -> Sequence @@ {}) ...

Only top voted, non community-wiki answers of a minimum length are eligible