73

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


46

The other methods described work well, but I am partial to exact answers. So, here it is. First, note that the Fibbonacci sequence has a closed form $$F_n = \frac{\Phi^n - (-\Phi)^{-n}}{\sqrt{5}}$$ where $\Phi$ is the GoldenRatio. Also, as observed elsewhere, we are looking only at every third term, which gives the sum $$\sum^k_{n = 1} \frac{\Phi^{3n} - (...


41

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


29

Here is a recursive method using Outer: FactorPoints[{1}] := {{0, 0}} FactorPoints[{n_}] := 3/2 Csc[Pi/n] Through[{Cos, Sin}[# (2 Pi)/n]] & /@ Range[n] FactorPoints[{n_, rest__}] := Flatten[Outer[Plus, 9/4 Csc[Pi/n] FactorPoints[{rest}], FactorPoints[{n}], 1], 1] FactorPlot[n_] := Graphics[Disk /@ FactorPoints[Sort[Flatten[ConstantArray ...


29

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


27

There are many ways to proceed, the best one uses FrobeniusSolve : I Since we know, that a x + b == y /. Solve[{-4 a + b == 11, 16 a + b == -1}, {a, b}] // Simplify {3 x + 5 y == 43} we find FrobeniusSolve[ {3, 5}, 43] {{1, 8}, {6, 5}, {11, 2}} a bit more straightforward way : II {x, y} /. Solve[ (a x + b == y /. Solve[ {-4 a + b == 11, 16 a + b == ...


25

You can just step through $i$ and $j$ while trying to simultaneously satisfy $$i^2+(i+1)^2=j^2+(j+1)^2+(j+2)^2$$ Just loop and if the inequality is too small on the left, increment $i$. If it's too small on the right, increment $j$. That looks like this: Clear[f, g, i, j]; f[i_] = i^2 + (i + 1)^2; g[j_] = j^2 + (j + 1)^2 + (j + 2)^2; max = 10^6; i = 1; j =...


24

Let me introduce the following animated approach: As you can see, I've slightly changed the way of diagram generation. The main differences are the following. 1. Now the diagrams are more symmetric. This is due to proper rotation after each sudivision. 2. As the main principle is to use factors in decreasing order, I consider 4 as a separate factor and ...


24

PrimeQ and FactorInteger use different algorithms. In general asking whether a number is prime is an easier problem than finding its factors. To quote the documentation, "PrimeQ first tests for divisibility using small primes, then uses the Miller–Rabin strong pseudoprime test base 2 and base 3, and then uses a Lucas test", while "FactorInteger switches ...


24

Fast algorithm n = 5566 IntegerPart[10 Mod[7 PowerMod[10, n - 1, 101], 101]/101] A brute force approach (see also these posts on stackoverflow :) ) may be fine for the current problem, but what if n is a huge number? The only possibility apart from guessing the periodic sequence of numbers as mgamer suggested would be to use modular arithmetics. Let me ...


23

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


23

Perhaps: Reduce`EulerPhiInverse[6] (* {7, 9, 14, 18} *) Not sure why such things are hidden & undocumented, perhaps because it's available through Reduce and Solve: Solve[EulerPhi[x] == 6, x, Integers] (* {{x -> -18}, {x -> -14}, {x -> -9}, {x -> -7}, {x -> 7}, {x -> 9}, {x -> 14}, {x -> 18}} *)


22

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


21

Here's my modest attempt: shiftMe[g_, 1] := g shiftMe[g_, {2, tag_Integer?Positive}] := If[OddQ[tag], Translate[Scale[g, 1/2], #] & /@ {{0, 1}, {0, -1}}, Translate[Scale[g, 1/2], #] & /@ {{1/2, 0}, {-1/2, 0}}] shiftMe[g_, k_?PrimeQ] := Translate[Scale[g, 1/k], Through[{Cos, Sin}[2 π #/k - π/(2 k)]]] & /@ Range[0, k - 1] /; k > 2 ...


21

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


21

A story of incremental improvement Let's look at the OP's original expression again, for reference: $$\sum_{m=1}^{c}\frac{1}{m}\sum_{d \mid m}\mu(d)n^{m/d}$$ Most people here are familiar with Sum[], and would not have much trouble translating the outer summation into Mathematica syntax. The inner part, $$\sum_{d \mid m}\mu(d)n^{m/d}$$ is not terribly ...


20

Straight iteration over the even valued Fibonacci numbers is fast. fibSum[max_] := Module[ {tot, n, j}, tot = 0; n = 0; j = 3; While[n = Fibonacci[j]; n <= max, j += 3; tot += n]; tot] Or one can use matrix products. This seems to be about the same speed. It has the advantage of not requiring a built in Fibonacci function. fibSum2[max_] := ...


20

Sum[Fibonacci[n], {n, 3, InverseFunction[Fibonacci][4000000], 3}] (* 4613732 *)


20

The built-in functionPrimeOmega gives you the number of prime factors and counts multiplicities. Therefore, this can easily be used to give you semi-primes as you have defined them: With[{r = Range[50]}, Pick[r, PrimeOmega[r], 2]]


19

A Trace reveals the problem: Product[If[PrimeQ[p], (p^2 + 1)/(p^2 - 1), 1], {p, 2, Infinity}] // Trace (* {Product[If[PrimeQ[p], (p^2 + 1)/(p^2 - 1), 1], {p, 2, Infinity}], {{PrimeQ[p], False}, If[False, (p^2 + 1)/(p^2 - 1), 1], 1}, Product[1, {p, 2, Infinity}], 1} *) The If[] statement is evaluated before the Product. In turn PrimeQ[p] ...


18

In general Mathematica cannot compute symbolically infinite sums over primes because of the lack of appropriate mathematical tools. However there are infinite products over primes which are basically well understood on the mathematical level. One famous example is the Euler formula for the Riemann zeta function, one of the most beautiful (and mysterious ...


18

RealDigits[1/243] (* {{{4, 1, 1, 5, 2, 2, 6, 3, 3, 7, 4, 4, 8, 5, 5, 9, 6, 7, 0, 7, 8, 1, 8, 9, 3, 0, 0}}, -2} *)


18

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


18

Cause Under the hood System`SquaresR is still calling functions in the context NumberTheory`. Partial output of: Needs["GeneralUtilities`"] PrintDefinitions @ SquaresR SquaresR[2, NumberTheory`SquaresRDump`n _ Integer?Positive] := Block[{NumberTheory`SquaresRDump`res}, NumberTheory`SquaresRDump`res = NumberTheory`SquaresRDump`squaresR2[...


17

Let us try to produce the solution without applying brute force, similar to mgamer's answer (that did not actually use Mathematica). Reduce[Mod[10^r - 1, 37] == 0, r, Integers] (* -> C[1] \[Element] Integers && C[1] >= 0 && r == 3 C[1] *) We see that the value of r can in fact be any nonnegative multiple of 3. The result sought is ...


17

I want to answer the part of the question, "How could my son be expected to find a prime factor?" Well, this depends on what your son has been taught, of course. A first thing to notice is that, since 99! is divisible by every prime less than 99, 99! - 1 is not divisible by any of those primes; so 101 is the smallest prime which could be a factor of it. So ...


17

Use Divisible: Divisible[a, 1000] False


16

If you are strictly interested in the number of trailing zeros in factorials $n!$, as the example in your question suggests, then consider the number of pairs of 2 and 5 in all the factors of numbers 1 through $n$. There is always a 2 to match a 5, so the number of fives gives the number of zeros. Integers divisible by 5 contribute one 5 to the total. ...


16

Is this what you are searching for? a = {-4, 11}; b = {16, -1}; dy = (b[[2]] - a[[2]])/(b[[1]] - a[[1]]); offset = u /. Solve[a[[2]] == dy*a[[1]] + u, u][[1]]; coords = {x, y} /. {Reduce[y == dy*x + offset && x > 0 && y > 0, {x, y}, Integers] // ToRules} (* {{1, 8}, {6, 5}, {11, 2}} *) Graphics[{PointSize[Large], ...


16

You could use FactorInteger to find out whether or not there are exactly two primes building up a number: SemiPrimeQ[n_Integer] := With[{factors = FactorInteger[n]}, Total[factors[[All, 2]]] == 2 ] The rest is easy: Select[Range[50], SemiPrimeQ] (* {4, 6, 9, 10, 14, 15, 21, 22, 25, 26, 33, 34, 35, 38, 39, 46, 49} *) And for those who like inline ...


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