## Finding Ramanujan's taxicab numbers

11

4

How to find Hardy-Ramanujan Numbers by using Mathematica?

Definition: Taxicab number is defined as the smallest number that can be expressed as a sum of two positive cubes in $n$ distinct ways.

For instance, The two different ways are:

$1729 = 1^3 + 12^3 = 9^3 + 10^3$

2FindInstance[a^3+b^3==c^3+d^3==1729&&a!=c&&a!=d,{a,b,c,d},Integers] returns in an instant. FindInstance can be surprisingly powerful. – Bill – 2017-01-11T07:43:40.103

4PowersRepresentations might be useful, e.g., PowersRepresentations[1729, 2, 3] returns {{1, 12}, {9,10}}. – Carl Woll – 2017-01-11T08:03:24.743

I wonder about finding the subsequent taxicab numbers? $2, 1729, 87539319, 6963472309248, 48988659276962496$ OEIS A011541

– dr.blochwave – 2017-01-11T08:03:44.560

@CarlWoll nice function. Too many functions, too little time :) – Nasser – 2017-01-11T08:18:57.613

8

I found the answer in Wolfram Mathworld

Taxicab[n_, max_] := {#[[1, 1]], First /@ Rest /@ #} & /@
Select[Split[
Sort[{Plus @@ #, #} & /@ Subsets[Range[Floor[max^(1/3)]]^3, {2}]],
First[#1] == First[#2] &], Length[#] == n &]

Taxicab[2, 10^5]


{{1729, {{1, 1728}, {729, 1000}}}, {4104, {{8, 4096}, {729, 3375}}}, {13832, {{8, 13824}, {5832, 8000}}}, {20683, {{1000, 19683}, {6859, 13824}}}, {32832, {{64, 32768}, {5832, 27000}}}, {39312, {{8, 39304}, {3375, 35937}}}, {40033, {{729, 39304}, {4096, 35937}}}, {46683, {{27, 46656}, {19683, 27000}}}, {64232, {{4913, 59319}, {17576, 46656}}}, {65728, {{1728, 64000}, {29791, 35937}}}}

First /@ %


${1729, 4104, 13832, 20683, 32832, 39312, 40033, 46683, 64232, 65728}$

ListPlot[First /@ Taxicab[2, 10^10], PlotStyle -> Red] 5

One way might be

n = 1729;
m = Floor[N[n^(1/3)]]
o = Subsets[Range[m], {2}]
Cases[o, {x_, y_} /; x^3 + y^3 == n] Another way

o = Total[#^3] & /@ o
Extract[o,Position[o, n]] Here are the 2 taxi numbers found up to 10000

   o = Last@Reap@Do[m = Floor[N[n^(1/3)]];
o = Subsets[Range[m], {2}];
o = Cases[o, {x_, y_} /; x^3 + y^3 == n];
If[o =!= {} && Length[o] >= 2,
Sow[{n, o}]
],
{n, 1729, 10000, 1}
]

Grid[Flatten[o, 1], Frame -> All] Verify 