Tag Info

Hot answers tagged

40

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


29

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


28

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


24

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


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

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]


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

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


20

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


20

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

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


17

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


17

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


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


14

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


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

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

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


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


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


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[{#, ...


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

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.


11

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}}} ] & /@ ...


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 = Compile`GetElement}, squareFreeQLSC = Compile[{{ll, _Integer, 1}}, Module[{res = 0, ctr = 1, sctr = 1, len = 0, start = 0, i = 0}, ...


11

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


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

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