Tag Info

49

If you want to make several sequences of the Collatz function for turning it into a graph, you probably want to memorize, which parts you already calculated. What we try to do is to create a graph like this (image from xkcd) When we would calculate the whole chain for each number until it (hopefully) reaches the end sequence 8,4,1 we do a lot of work over ...

29

This is the Collatz function I know: Collatz[1] := {1} Collatz[n_Integer] := Prepend[Collatz[3 n + 1], n] /; OddQ[n] && n > 0 Collatz[n_Integer] := Prepend[Collatz[n/2], n] /; EvenQ[n] && n > 0 Generating a graph from this is easy: Graph[(DirectedEdge @@@ Partition[Collatz[#], 2, 1]) & /@ Range[500] // Flatten // Union, ...

24

I can't take much credit for this answer--I hadn't even got version 10.2 installed until J. M. commented to me that these functions could be written efficiently in terms of the Hamming weight function. But, it is understandable that he doesn't want to write an answer using a smartphone. The definition of the built-in ThueMorse is: ThueMorse[n_Integer] := ...

21

We can exploit the built in LogGamma: x = 12345678987654321; Ceiling[LogGamma[N[x + 1]]/Log[10]] 193299018111544064 Edit, Addressing precision: We have naively for $n > 1$, that $n! < n^n$. Taking logs of both sides gives the (not very tight) bound $\log\Gamma(x + 1) < x \log(x)$ for $x > 1$. This means if we want the number of digits of ...

14

Your code works fine, but it's missing half the roots, and a Flattening of the list of numbers prior to applying Re and Im helps. Adding those in: data = Flatten[ Table[{(-b + Sqrt[b^2 - 4 a c])/(2 a), (-b - Sqrt[b^2 - 4 a c])/(2 a)}, {a, 1, 20}, {b, -20, 20}, {c, -20, 20}]]; ListPlot[{Re[#], Im[#]} & /@ data, PlotRange -> {{-3, ...

12

I wondered if Chip's answer was exactly correct, given Daniel's comment about machine precision. So I did it a little differently with higher precision in a way that gives good confidence in the result. (It turns out that the machine precision answer is correct.) LogGamma can be expanded around infinity thusly: Series[LogGamma[z], {z, Infinity, 4}] to ...

10

A graph representation: opts = {VertexLabels -> "Name", ImagePadding -> 10}; g[n_] := Graph[Flatten[Thread[DirectedEdge[#, Most@Divisors@#]] & /@ Divisors@n], opts] aa = g[30] Then (v10 only, thanks to @billc for running it for me): fp = FindPath[aa, 30, 1, Infinity, All] (* {{30, 1}, {30, 15, 1}, {30, 10, 1}, {30, 6, 1}, {30, 5, 1}, ...

10

Brute forcing it: (The edit at the end is a much faster alternative) n = 9; IntegerPartitions[n + 1, {3}] (* {{8, 1, 1}, {7, 2, 1}, {6, 3, 1}, {6, 2, 2}, {5, 4, 1}, {5, 3, 2}, {4, 4, 2}, {4, 3, 3}}*) are the ways to split ten digits. The numbers on the first row can't produce viable sums, so we need to check only the partitions on the bottom row. ...

10

There are several problems with your code. The first one is that you are missing a couple of semicolons to suppress output and delineate substatements in a compound function. The second problem is that you are trying to assign a new value to x within the function definition. This doesn't work. x already has the value of whatever number you give. You need ...

10

Brute-force, but compact: DeleteCases[Table[{k, PowersRepresentations[k!, 3, 2]}, {k, 10}], {___, 0, ___}, {3}] {{1, {}}, {2, {}}, {3, {{1, 1, 2}}}, {4, {{2, 2, 4}}}, {5, {{2, 4, 10}}}, {6, {{8, 16, 20}}}, {7, {{4, 20, 68}, {12, 36, 60}, {20, 44, 52}}}, {8, {{8, 16, 200}, {8, 80, 184}, {40, 88, 176}, {72, 120, 144}, {80, 104, 152}}}, {9, {{8, 304, ...

9

I'll assume the title reflects the goal, as opposed to the example. If this is not the case, comment and I'll delete. distPrimePart[n_] := Module[{l = 1, p}, Join @@ Reap[While[(p =Prime@Range@(PrimePi@(n - Tr@Prime@Range@(l - 1)))) != {}, Sow[Select[IntegerPartitions[n, {l}, p], Length@# == Length@DeleteDuplicates@# &]]; l++]][[2, 1]]]; ...

9

I do a lot of cybersecurity competitions where we crack crypto, so I'm used to grappling with Mathematica for ring algebra. The sole thing Mathematica honestly isn't great for is cryptography. For this stuff, I generally just use SageMath Cloud, because it has all of the above algorithms built into DiscreteLog. You just throw your values at the function and ...

8

As this is a special-functions question, I feel justified in using a bit of heavy artillery. Here goes nothing... In effect, what the OP seems to want to do is to evaluate $$\sum_{n=1}^\infty \frac{(q^{n+1};q)_\infty}{(q^n;q)_\infty} q^{n-1}$$ (where $(a;q)_n$ is the $q$-Pochhammer symbol) by approximating it with its partial sums. However, there is a ...

8

You're setting x as a side-effect and that (I believe) makes your code difficult to follow. This one is equivalent using a "more functional" programing style. As @Guesswhoitis suggested, NestList[] is your friend. a[n_] := 3 n - (5 + (-1)^n)/2 b[m_] := IntegerExponent[m, 2] nextSeq[n_] := (#/2^b@#) &[1 + 3 n] full[j_] := NestList[nextSeq, a@j, b[a@j ...

8

Not very efficient, but you may find it useful for some experiments. I perused the code from the link you provided (kuba's), although there are better alternatives in the answers. ClearAll[spiral, genTri, mp]; spiral[n_?OddQ] := Nest[ With[{d = Length@#, l = #[[-1, -1]]}, Composition[ Insert[#, l + 3 d + 2 + Range[d + 2], -1] &, ...

7

Here's another perspective for you. cf[x_] := ColorData[{"DeepSeaColors", {2, 0}}][Mod[Sqrt[8 x + 1] + 1, 2]]; Graphics[{PointSize[Small], cf[#], Point[ulamCoords[#]]} & /@ Range[1024], Background -> Black] This color function allows us to (visually) trace "triangularity level curves" of a sort, where the brightest points are triangular ...

7

This works for all numbers which are not multiples of $\text{lcm}(1, \dots, 20) = 232792560$: smallest[n_] := LengthWhile[Range[3, 20], Divisible[n, #] &] + 3 If you use $50$ instead of $20$, you get $3099044504245996706400$ as the forbidden number, which might be more acceptable to you. You could compile this to get something which might be faster. ...

7

It seems you are calculating legs of Pythagorean triples, $\{a,b\}$, for $b<a/\sqrt{2}$. I used your isSq function, and added a different test for GCD[a,b]==1. RelativePrimesA[n_Integer] := Block[{max = Floor[n/Sqrt[2]]}, Complement[Range[max - 1], Apply[Sequence, Map[Range[#, max - 1, #] &, FactorInteger[n][[All, 1]]]]] ] The ...

7

Sure, try for example: pr[14709321003111578837870501266345370175409, 2, 2] There are many things in MMA where small cases/edge cases can be done much more quickly with user code, this is one of them. The advantage here is that PowersRepresentation can handle huge cases...

6

Select[ NestWhileList[NextPrime, 100, # < 9999 &], And @@ PrimeQ[FromDigits[Permutations[IntegerDigits[#]]]] & ] {113, 131, 199, 311, 337, 373, 733, 919, 991}

6

With modest preprocessing we get a factor of 9 or so for large inputs just by chunking into 12 bit pieces and using a compiled lookup function. m = 12; Timing[tmLookup = Table[Mod[Total[IntegerDigits[j, 2]], 2], {j, 0, 2^m - 1}];] (* Out[49]= {0.00157, Null} *) Some of the option settings are probably overkill. tmLookupCSmall = With[{tmtable = ...

6

You made a few mistakes. jk[0] should be 0 in your code and your function tr is wrong. Corrected version: t[0] = 0; t[1] = 0; t[2] = 1; t[n_] := t[n] = LengthWhile[Range[1, 11], Divisible[n, #1] &] + 1 Sum[Nest[t, m, 3], {m, 1, 2006}] 1171 10x faster version: t[n_] := t[n] = Module[{i = 1}, While[MemberQ[Divisors[n], i], i++]; i];

6

I discussed the prime zeta function at some length in this math.SE answer. In particular, the infinite Möbius inversion $$P(s)=\sum_{k=1}^\infty \frac{\mu(k)}{k}\log\zeta(ks)$$ is the actual computational formula used, as recommended in Fröberg's paper. (It is also noted there that numerical evaluation becomes more difficult at values near the imaginary ...

6

I doubt if this question is on the correct forum, but... this can be accomplished using Minimize with constraints, if search range is bound (sum below 2000 in this case): Minimize[{a^3 + b^3, a^3 + b^3 == c^3 + d^3 && a > 0 && b > 0 && c > 0 && d > 0 && ! (a == c && b == d) && ! (a ...

5

Using the formula given in the arXiv preprint Patrick linked to for the "carefree constant" gives: Exp[NSum[(-1)^k PrimeZetaP[k] (1 - LucasL[k])/k, {k, 2, ∞}, Compiled -> False, Method -> "AlternatingSigns", NSumTerms -> 20, WorkingPrecision -> 30]] 0.704442200999165592738713909247 Note that this agrees with the result in the OEIS ...

5

I'm surprised no one bothered to pursue the method given in Simons and Alder's paper, as commented by KConrad. A Mathematica implementation of their idea is surprisingly short: n = 10; MapThread[With[{z = (#1 + 1)/2}, 3 #2 + 2 z - 2 + {z, 0}] &, LinearRecurrence[{10, -1}, #, {1, n} + 1] & /@ {{1, 5}, {0, 2}}] {{13, 10}, {133, 108}, ...

5

I like your questions since we seem to be doing similar things. Note that your code correctly finds the normalized spacings between all pairs of zeros. This is what the pair correlation function is, but you only want to plot the normalized spacings up to a limit, usually 3. Values returned by your code, MartinPairs[t] where list t contains the imaginary ...

5

Just to separate this from a package-based answer. In Mathematica 10.2, you can now do this with the built-in function SmithDecomposition. So using the same matrix from my previous answer: mat = {{1, 2, 3}, {-2, 3, 1}, {3, 2, 1}}; MatrixForm /@ SmithDecomposition[mat] Where the second element is the Smith normal form.

5

This gives you the irreducible polynomials up to order n - 1 in $\mathbb Z_2[x]$ n = 5; Table[Pick @@ Transpose[({#, IrreduciblePolynomialQ[#, Modulus -> 2]} & /@ (FromDigits[#, x] & /@ Tuples[{0, 1}, i]))], {i, n}] // Column However, for degree 31 there are 2^32 == 4,294,967,296 tuples to ...

5

Lucas' correspondence theorem, here or here, states that a binomial coefficient Binomial[n,k] is equivalent to, mod prime p, the product of binomial coefficients Binomial[ni,ki], where ni and ki are the digits in the base p expansion of n and k, respectively. The function BinomialMod[n,k,p] does this calculation for prime modulus p. BinomialMod[n_, k_, p_] ...

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