29

I'm really surprised if this question isn't a duplicate, but since I failed to find one that asked about the Fibonacci sequence rather than someone using it as an example, I'll answer. The most natural approach, besides using the built-in Fibonacci function, recursion: f[0] = 0; f[1] = 1; f[n_] := f[n] = f[n - 1] + f[n - 2] (* note memoization *) Array[f,...


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


23

The sum of consecutive numbers from $a$ to $b$ is $$\frac{(a+b)(b-a+1)}{2}$$ hence simply f[n_] := {a, b} /. Solve[(a + b) (b - a + 1)/2 == n && 0 < a < n && 0 < b < n, {a, b}, Integers] f[45] // AbsoluteTiming {0.019466, {{1, 9}, {5, 10}, {7, 11}, {14, 16}, {22, 23}}} It is straightforward and rather fast. As a test ...


18

My own take on this: Clear[f] f[0] = 0; f[n_] := f[n] = If[Or[MemberQ[Last /@ Most[DownValues[f]], f[n - 1] - n], f[n - 1] < n], f[n - 1] + n, f[n - 1] - n] f /@ Range[0, 11] (* {0, 1, 3, 6, 2, 7, 13, 20, 12, 21, 11, 22} *) We can draw the figure using With[{list = Table[f[n], {n, 0, 30}]}, Show[Graphics@*Circle @@@ Partition[Flatten[{ ...


17

Just the visualization part using ParametricPlot: recamanSequencePlot1 = ParametricPlot[ Evaluate[Map[RotationTransform[Pi/4] @ {Mean @ # + (#[[2]] - #[[1]])/2 Cos[t], (#[[2]] - #[[1]])/2 Sin[t]} &, Partition[#, 2, 1]]], {t, 0, -Pi}, AspectRatio -> Automatic, Axes -> False, ImageSize -> Large] &; Using ...


16

fibSequences[n_?EvenQ] := Nest[Accumulate[Join[{1, 0}, #]] &, {}, n/2] fibSequences[n_?OddQ] := Most@Nest[Accumulate[Join[{1, 0}, #]] &, {}, (n + 1)/2] fibSequences[10] {1, 1, 2, 3, 5, 8, 13, 21, 34, 55} fibSequences[9] {1, 1, 2, 3, 5, 8, 13, 21, 34}


15

IF you can assume 1) they are integers, 2) they are ascending, and 3) no repeats, THEN your last idea should work Last[list]-First[list]==Length[list]-1 Or you could Union[Differences[list]]=={1} Without assumptions (2) and (3): Union[Differences[Sort[list]]]=={1}


15

We can substantially speed up the calculation for large primes by making some elementary observations about the Fibonacci series. There are two motivating ideas behind them: Almost all the properties of the Fibonacci series rely only on the field axioms, so that the theory of Fibonacci series (and linear recurrences in general) holds practically without ...


15

Is Tribonacci defined? First you should notice that Tribonacci is not already defined by Mathematica. Compare the defined Fibonacci ?Fibonacci with ?Tribonacci You could have guessed by the color of the function in the front-end display, black for defined and blue for undefined. Fibonacci n-Step Number Now we can define the even more general ...


14

This is probably defeating your professor's unspoken desire, but no one explicitly said you required a recursion. It may or may not entertain you to know Binet's formula. Without checking, I would guess that this approach is similar to how the built in function computes Fibonacci numbers. It is clearly computationally cheaper than any sort of recursion or ...


13

A short one: consecutiveQ = Most[#] == Rest[#] - 1 &


13

A combination of IntegerPartitions, RandomChoiceand RandomSample: n = 30; RandomSample @ RandomChoice @ IntegerPartitions[0, {n}, {-1, 0, 1}] {-1, 1, 1, 1, 1, -1, -1, 0, -1, 1, 1, -1, -1, -1, 1, -1, 1, 1, -1, 0, 1, -1, -1, 1, -1, -1, 1, 1, -1, 1} Total @ % 0 You can also do RandomSample @ PadRight[Flatten @ ConstantArray[{1, -1}, RandomChoice[...


13

If you don't care about extra space, we can employ a reverse lookup table: seenQ[0] = True; a[0] = 0; a[n_] := a[n] = With[{prev = a[n - 1]}, (seenQ[#] = True; #) &[ If[prev > n && ! TrueQ[seenQ[prev - n]], prev - n, prev + n] ] ] Block[{$RecursionLimit = ∞}, Do[a[k], {k, 10^6}] // AbsoluteTiming ] {8.55911, Null} a /@ Range[0, ...


13

You can use Split: Last /@ Split[z, #2 == # + 1&] {113, 121, 476, 529, 538, 544} First /@ Split[z, #2 == # + 1&] {113, 117, 475, 529, 538, 542}


12

f[n_]:=Union @@ NestList[{{0,1},{1,1}}.# &, {1, 1}, n] EDIT fib[n_]:=NestList[{{0,1},{1,1}}.# &, {0, 1}, n][[All,1]] and MatrixPower method: fn[n_]:=First[MatrixPower[{{1,1},{1,0},n-1].{1,0}]


12

There is a straightforward answer analogous to that in Maple : Coefficient[ Sum[t^i, {i, 5}] Sum[t^i, {i, 2, 6}] Sum[t^i, {i, 3, 9}], t, 15] 19 This can be verified by expanding the polynomial: Expand[ Sum[t^i, {i, 5}] Sum[t^i, {i, 2, 6}] Sum[t^i, {i, 3, 9}]] However you can do it in many different ways e.g. by exploiting CoefficientRules or ...


12

Defining the "Collatz"-Function like you did is straight-forward, but in the sense of Mathematica not optimal. When computing the length of a Collatz-Sequence a lot of duplicate calculations are done. So defining: collatz[n_] := collatz[n] = If[EvenQ[n], n/2, 3*n + 1] prevents Mathematica from doing duplicate evaluation. This is more efficient than ...


12

LinearRecurrence is useful here: LinearRecurrence[{1, 1, 1}, {1, 1, 2}, 9] {1, 1, 2, 4, 7, 13, 24, 44, 81} Related: Fibonacci Sequence Generator How to deal with recursion formula in Mathematica?


12

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


11

In Mathematica 10.2 one can use the new function SequenceFoldList: fib[n_] := SequenceFoldList[Plus, {0, 1}, ConstantArray[0, n - 1]]; fib[15] {0, 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, 144, 233, 377, 610} Use SequenceFold to obtain just the last element.


11

@Artes's use of Coefficient certainly seems the most straightforward and probably the best for small examples. If the polynomials have very many terms, the use of SeriesData to represent the polynomials will give better performance. The multiplication of series is efficient in Mathematica. One should note that it is truncated beyond the maximum degree ...


11

Recursive Function Let's start with simple recursive function provided by @corey979: ClearAll[fRecursive] fRecursive[1] = 2; fRecursive[n_] := fRecursive[n] = Count[Table[fRecursive[k], {k, 1, n-2}], fRecursive[n - 1]] It works as expected: Array[fRecursive, 15] (* {2, 0, 0, 1, 0, 2, 1, 1, 2, 2, 3, 0, 3, 1, 3} *) but it's a bit slow: Table[...


11

I took it as a challenge to avoid using Solve, which can be slower than a direct assault. If $a$ is the first number in the sum of consecutive positive integers, and $k$ is the count of integers summing to $n$, then $n=k*a+k(k-1)/2$. Solve this for $a=n/k-(k-1)/2$, with bounds $1 \le k \le {\rm Floor}[(\sqrt{8n+1}-1)/2]$. Consider the odd and even divisors ...


11

Have you thought about whether this is a reasonable thing to try to compute exactly? There is a closed form formula for Fibonacci numbers which allows us to estimate the number of digits in the answer: Fibonacci[k] // FunctionExpand (* ((1/2 (1 + Sqrt[5]))^k - (2/(1 + Sqrt[5]))^k Cos[k π])/Sqrt[5] *) For large k the answer is approximately GoldenRatio^k /...


10

You need to specify assumptions: In[1]:= FunctionExpand[StirlingS2[n, 10], n > 0 && Mod[n, 1] == 0] Out[1]= -(1/362880) + 2^(-8 + n)/315 + 1/135 2^(-7 + 2 n) + 1/315 2^(-8 + 3 n) - 3^(-3 + n)/1120 + 1/5 2^(-7 + n) 3^(-3 + n) - 5^(-2 + n)/576 + 1/567 2^(-8 + n) 5^(-2 + n) - 7^(-1 + n)/4320 - 9^(-2 + n)/4480


10

Also taking your question at face value, but making the fix faster: fibonacciSequence2[n_] := Module[ {fPrev = 0, fNext = 1, i = 0, list = {0}}, While[i++ < n, {fPrev, fNext} = {fNext, fPrev + fNext}; list = {fPrev, list} ]; Reverse@Flatten[list] ] fibonacciSequence2[5000] // Timing This way of constructing a list has a name, it's ...


10

As noted by the Wizard, LinearRecurrence[] is an excellent way to handle integer sequences based on linear difference equations. Had that mechanism not been available, one can exploit the relationship between linear recurrences and powers of the Frobenius companion matrix of the recurrence's characteristic polynomial: SetAttributes[Tribonacci, Listable]; ...


10

you mean something like this? Graphics[{Red, Rectangle[{0, 0}, {Fibonacci@6, Fibonacci@5}], Green, Rectangle[{0, 0}, {Fibonacci@4, Fibonacci@5}], Yellow, Rectangle[{0, 0}, {Fibonacci@4, Fibonacci@3}], Blue, Rectangle[{0, 0}, {Fibonacci@2, Fibonacci@3}], Pink, Rectangle[{0, 0}, {Fibonacci@2, Fibonacci@1}]}] but if you want the real thing, here ...


10

NestList[] is very handy for situations like this: tr[Polygon[p_]] := Polygon[Composition[TranslationTransform[First[p]], AffineTransform[{{0, -1}, {1, 0}}/GoldenRatio], TranslationTransform[-Last[p]]] @ p] g1 = Graphics[{EdgeForm[Black], MapIndexed[{ColorData[61] @@ #2, #1} &, NestList[tr, Polygon[{{GoldenRatio, 0}, {GoldenRatio, 1}, {0, 1}, {...


10

The problem is the following: Mod[Plus @@ IntegerDigits[n, 2], 2] Mod[2 + n, 2] This happens because IntegerDigits stays unevaluated for non integer inputs: IntegerDigits[n, 2] IntegerDigits[n, 2] Note that this sum remains unevaluated: Sum[ThueMorse[n]/(n + 1)^s, {n, 0, Infinity}] Sum[ThueMorse[n]/(n + 1)^s, {n, 0, Infinity}] Ideally Alpha should ...


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