Tag Info

Hot answers tagged

47

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


28

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


21

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


19

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


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


16

As far as obtaining a True/False answer: In[11]:= Element[Sqrt[2], Rationals] Out[11]= False


15

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


13

Update: the lhs of $i^2+(i+1)^2=j^2+(j+1)^2+(j+2)^2$ is always odd so $j$ should be even. The fastest solution I found: max = 10^12; {(Sqrt[3 + 6 (# + 1)^2] - 1)/2, #, #^2 + (# + 1)^2 + (# + 2)^2} & @@@ (2 Position[#, 0]) &@UnitStep[Abs[# - Round[#]] - 1.*^-10] &[ Sqrt[0.75 + 1.5 #^2] - 0.5] &@ Range[3., Sqrt[max/3.], 2] // ...


12

Clear[fa, ga]; fa = Total[{#, # + 1}^2] &; ga = Total[{#, # + 1, # + 2}^2] &; Update: A closed form function soln = Assuming[{C[1] ∈ Integers && C[1] >= 0 && x > 0 && y > 0}, Simplify@ Reduce[Total[{x, x + 1}^2] == Total[{y, y + 1, y + 2}^2], {x, y}, Integers]] /. C[1] -> n; ...


10

You are asking for a solution to the equation $10^r\equiv 1$, mod $n$, where in your particular case $n=37$. The multiplicative order is the smallest exponent $r$ such that $x^r\equiv 1$, mod $n$. The multiplicative order is given by the Mathematica command MultiplicativeOrder[x,n], and corresponds to the "Foo" you asked for in your comment to @mgamer. ...


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


9

Find the first positive integer that satisfies the condition: NestWhile[# + 1 &, 1, ! Element[(10^# - 1)/37, Integers] &] 3 Or r = 0; NestWhile[Element[(10^(++r) - 1)/37, Integers] &, False, Not]; r 3 Or Block[{r = 1}, While[! Element[(10^r++ - 1)/37, Integers]]; r - 1] 3


9

Count[IntegerDigits[#!], 0] & /@ Range[1, 100000, 2000] // ListLogPlot


9

This is quite good: f[d_, n_] := With[{x = Pick[d, Thread[Accumulate[d] - n < 0]]}, Scan[f[x, n - Total[#]] &, Subsets[Complement[d, x], {1, Infinity}]]] f[_, 0] := Throw @ True; weird[n_] := (DivisorSigma[1, n] > 2 n) && ! TrueQ @ Catch @ f[Most @ Divisors[n], n] Select[Range[10000], weird] // AbsoluteTiming (* {1.450002, {70, 836, ...


8

Let me start by saying that this problem is probably best solved with a procedural backtracking algorithm, like the one given here. This makes Mathematica a poor choice for tackling it. In fact, judging from this sci.math topic from 1994 the people who originally derived the complete list of PPDIs did it in C. But since we're here to talk about Mathematica, ...


8

In a nutshell, factoring integers is a harder problem than determining primality. This seeming asymmetry is exploited as a component in modern computer security systems (in the form of the RSA cryptosystem). Determining primality has long been known to be doable in polynomial time using a variety of probabilistic algorithms, many of which (as mentioned by ...


8

(* Input: Range of even numbers --- Output: Primitive weird numbers *) Block[{$RecursionLimit=Infinity}, subOfSum[ss_, kk_, rr_]:= Module[{s=ss, k=kk, r=rr}, If[ s+w[[k]] >=mm && s +w[[k]] <=m, t=False; Goto[ done](*Found*), If[s +w[[k]]+w[[k +1]] <=m, subOfSum[s +w[[k]], k+1, r-w[[k]]]]; If[s+r -w[[k]] ...


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

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


7

Counting Strings may be faster, so I propose the string version: countZeros[x_Integer] := StringCount[IntegerString[x!], "0"] Then: countZeros[1000] 472


7

It looks like you want to plot the phase-only information of a complex function. Using the following helper functions for plotting the phase-only information complex functions: hue = Compile[{{z, _Complex}}, {Mod[3 π/2 + Arg[z], 2 π]/(2 π), 1, If[Abs[z] > 10^-3, 1, 0]}, CompilationTarget -> "C", RuntimeAttributes -> {Listable}]; ...


6

Mathematica is using an exhaustive search for your first example, testing each value of n from 2 to 2^10. By default it won't use this method if the number of test cases exceeds 10000. So in your second example it cannot resolve the Exists expression and returns it unchanged. You can increase the maximum number of points for the exhaustive search using ...


6

The $n^{th}$ triangle number satisfies Binomial[n+1,2], therefore, solving for m=Binomial[n+1,2] and checking if the solution is an integer gives the answer directly. triangularQ[m_] := IntegerQ@(n /. First@Solve[Binomial[n + 1, 2] == m, n]) {#, triangularQ[#]} & /@ Range[2, 28] // TableForm reference: http://en.wikipedia.org/wiki/Triangular_number ...


6

There is an especially useful function HarmonicNumber appearing most likely the best approach in similar tasks since its implementation is optimized and it has close relations to number theoretic functions like the Riemann zeta function ζ represented in Mathematica by Zeta, basically HarmonicNumber tends to Zeta for Re[z] > 1 : Limit[ HarmonicNumber[n, ...


6

Instead of a brute-force approach on larger and larger powers of ten, this constructs the multiplier digit by digit by dividing from the bottom up. There is only one choice for each digit. This is much faster than the brute-force approach when the number of digits is large. nines[n_ /; n > 2 && OddQ[n] && ! Divisible[n, 5]] := ...


6

There is a simpler function instead of GCD that allows you to skip the comparison with 1: CoprimeQ. Using it, we can do this: Z[n_] := With[{i = Range[n]}, Pick[i, CoprimeQ[i, n]]] Z[21] (* ==> {1, 2, 4, 5, 8, 10, 11, 13, 16, 17, 19, 20} *) Here I deliberately tried to avoid any cryptic symbols (although perhaps that should be par for the course in a ...


6

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


6

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


5

SumFact[n_: Integer] := Apply[Plus, Map[#[[1]] #[[2]] &, FactorInteger[n]]]; A = {}; lastFac = SumFact[10^7 - 1]; Do[ If[(z = SumFact[n]) == lastFac, AppendTo[A, n]]; lastFac = z, {n, 10^7 + 1, 10^8, 2}]; A This took about 15 minutes on my MacPro and gave 417 candidates. There should be no problem parallelizing this code and getting up to n = ...


5

Here is another approach (based on $t_n=\frac{n(n+1)}{2}$): fn[x_] := Mod[Sqrt[1 + 8 x], 2] == 1 For the test example fn[3003] is true: Just for fun (but factoring extremely large numbers an issue): an[x_?(# > 0 &)] := Abs[# - 2 x/#] & @@ Nearest[Divisors[ 2 x], Sqrt[2 x]] == 1 an[0] := True Just for illustration (and not proof but are ...



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