Hot answers tagged

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] := ...


20

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


19

As far as obtaining a True/False answer: Element[Sqrt[2], Rationals] (* False *)


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


11

How about FullSimplify[ Exists[{a, b}, Element[a, Integers] && Element[b, Integers] && ! MemberQ[Divisors[b], a] && a^2/b^2 == 2]] (* False *)


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


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


8

Never use pattern matching unless you absolutely have to. Using Cases instead of Select can make a huge difference. Vectorize operations. Use Range instead of Table if you can. Test several things at once. And[test1, test2, test3] will abort when it can for maximum efficiency ("short circuit evaluation"). Taking this into consideration your code looks ...


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

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


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


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


5

FindInstance supports an optional argument that defines how many instances it should find. For example, this code will find 10 distinct solutions to your equation: {x, y, z} /. FindInstance[ x^2 + y^2 == z^2 + 1 && x > 0 && y > 0 && z > 0, {x, y, z}, Integers, 10] {{2, 1, 2}, {600, 1, 600}, {1, 69, 69}, {114, 1, ...


5

Diophantus's approach Diophantus (Book II, problem 9) gives parameterized solutions to x^2 + y^2 == z^2 + a^2, here parametrized by C[1], which may be a rational number (different than 1). We can use his method to find solutions to the OP's case, a == 1. Since Diophantus' method produces rational solutions, we have to clear denominators to get a solution ...


5

The quickest route here, from a syntactic standpoint, is to use Reduce, which allows you to request that the equation to be simplified by eliminating a set of variables, and to restrict those variables to a given domain, all at once: In[1]:= Reduce[a^2/b^2 == 2, {a, b}, Integers] Out[1]= False As shown in Marius Ladegård Meyer's answer, you need to square ...


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

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

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