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: Element[Sqrt[2], Rationals] (* 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

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

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

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


7

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


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

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

Copied from OEIS without thinking about it: Needs["Combinatorica`"] (*then*) fQ[n_] := Block[{d, l, t, i}, If[DivisorSigma[1, n] > 2 n && Mod[n, 6] != 0, d = Take[Divisors[n], {1, -2}]; l = 2^Length[d]; t = Table[NthSubset[j, d], {j, l - 1}]; i = 2; While[i < l && Plus @@ t[[i]] != n, i++] ]; If[i == l, ...


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

A good opportunity for the lowly procedural loop. Reap[Clear[h]; n = 10; Do[If[TrueQ[h[i/j]], , h[i/j] = True; Sow[{i, j}]], {j, 2, n}, {i, j - 1}]][[2, 1]] (* {{1, 2}, {1, 3}, {2, 3}, {1, 4}, {3, 4}, {1, 5}, {2, 5}, {3, 5}, {4, 5}, {1, 6}, {5, 6}, {1, 7}, {2, 7}, {3, 7}, {4, 7}, {5, 7}, {6, 7}, {1, 8}, {3, 8}, {5, 8}, {7, 8}, {1, 9}, {2, 9}, {4, ...


5

Here is a direct implementation of your series formula: a[1] = 1 a[n_] := a[n - 1] + (Prime[n] - 1)/2 You can speed up calculation by memoizing a: a[1] = 1 a[n_] := a[n] = a[n - 1] + (Prime[n] - 1)/2


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



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