Graphing a large set of Pythagorean triples

Questions
,
1

Sorry, I need to give more info on my problem.

I have a large set of primitive Pythagorean triples, generated by the code in the PrimitivePythagoreanTriple.nb:

prim=With[{max=100},\[IndentingNewLine]Map[Last,List@@(Reduce[x^2+y^2\[Equal]z^2 && 0< x < y <max&&0<z<max &&GCD[x,y,z]\[Equal]1,{x,y,z},Integers,Backsubstitution->True]/.And:>List),{2}]]

I wish to graph this discrete set in the xy-plane using ListPlot (after I add Table[ … ] to the resulting set of pairs).

This requires changing the triples {x,y,z} to pairs {x,y}, same first and second coordinates.
I can do it on a single triple, obviously, but how do I write a code to make the new list of pairs from the list of triples?

Here’s a sample of what the outcome should look like (see attached).

I’ve tried everything I can find and/or think of.
Any suggestions will be appreciated.

Thanks,
JP

Screen Shot 2021-06-18 at 5.39.13 PM.png
Screen Shot 2021-06-18 at 5.39.13 PM.png806×691 68.4 KB

2

Just guessing at what you are trying to do. Using genPTunder from this answer on MSE.

genPTunder[25] // Map[Most]
(* {{3, 4}, {5, 12}, {6, 8}, {7, 24}, {8, 15}, {9, 12}, {12, 16}, {15, 20}} *)

genPTunder[25] // GroupBy[Most -> Last]
(* <|{3, 4} -> {5}, {5, 12} -> {13}, {6, 8} -> {10}, {7, 24} -> {25}, 
     {8, 15} -> {17}, {9, 12} -> {15}, {12, 16} -> {20}, {15, 20} -> {25}|> *)

genPTunder[25] /. {a_, b_, c_} :> {a, b} -> c
(* {{3, 4} -> 5, {5, 12} -> 13, {6, 8} -> 10, {7, 24} -> 25, {8, 15} -> 17,
    {9, 12} -> 15, {12, 16} -> 20, {15, 20} -> 25} *)

genPTunder[25] // Map[Most /* Callout] // ListLinePlot[#, Mesh -> All] &

5968plot.png
5968plot.png450×284 5.8 KB

genPTunder[500] // Map[Most] // ListLinePlot

4116plot.png
4116plot.png450×284 24.6 KB

3

Hi James,

The code you provided formatted correctly.

prim = With[{max = 100}, 
  Map[Last, 
   List @@ (Reduce[
       x^2 + y^2 == z^2 && 0 < x < y < max && 0 < z < max && 
        GCD[x, y, z] == 1, {x, y, z}, Integers, 
       Backsubstitution -> True] /. And :> List), {2}]]

It is hundreds of times slower than genPTunder that I referred to in my previous reply.

It looks like the triples were filtered in some way to generate the image you provided. So this does not generate an identical image. It does match the image on Wikipedia.

genPTunder[6000] // Map[Most] // Join[#, Map[Reverse, #]] & //
  ListPlot[#, AspectRatio -> 1, ImageSize -> 600, PlotStyle -> Blue] &

1217plot.png
1217plot.png750×736 42 KB

4

Thanks, I’m not familiar with genPTunder.
I’ll look into it.
Your graph looks like you have all Pythagorean triples, not just the primitive ones.

5

Missed that. Easy to modify

coprimePT = genPTunder[10000] // Map[Most] // Select[CoprimeQ @@ # &];
coprimePT // 
 ListPlot[{#, Map[Reverse, #]}, AspectRatio -> 1, ImageSize -> 600, 
   PlotStyle -> {Red, Black}] &

8454plot.png
8454plot.png750×722 20.4 KB

6

Great!
Very interesting!
I was aware of this approach to generating PPTs, but I was not aware of the difference in time and memory it would determine.
Thanks again,
JP

7

You may also find my method of generating PPTs useful. It generates all ppt’s {a, b, c}, with the short leg as the input, where a<b<c. It is easily modified if you want all ppts with any leg equal to the input value by changing this part # > x to # > 0.

pyths[x_Integer] := (t = Select[Divisors[x^2], # <= x &]; 
  m = Sort[Select[(x^2 - t^2)/(2 t), IntegerQ[#] && # > x &]]; 
  Table[{x, m[[i]], Sqrt[x^2 + m[[i]]^2]}, {i, 1, Length[m]}])

or primitive ppt’s

primpyths[x_Integer] := (t = Select[Divisors[x^2], # <= x &]; 
  m = Sort[Select[(x^2 - t^2)/(2 t), 
     IntegerQ[#] && # > x && GCD[x, #] == 1 &]]; 
  Table[{x, m[[i]], Sqrt[x^2 + m[[i]]^2]}, {i, 1, Length[m]}])

pyths[1000]

{{1000, 1050, 1450}, {1000, 1875, 2125}, {1000, 2400, 2600}, {1000, 
  3045, 3205}, {1000, 4950, 5050}, {1000, 6210, 6290}, {1000, 9975, 
  10025}, {1000, 12480, 12520}, {1000, 15609, 15641}, {1000, 24990, 
  25010}, {1000, 31242, 31258}, {1000, 49995, 50005}, {1000, 62496, 
  62504}, {1000, 124998, 125002}, {1000, 249999, 250001}}

primpyths[1000]

{{1000, 15609, 15641}, {1000, 249999, 250001}}
8

Paul,
I think I used this a variation on this method to construct a previous notebook:
https://www.notebookarchive.org/ppt-graphbrief-nb--2021-06-6y24ve8/

9

James, Thank you for the link, however I can’t seem to get it to run, there seems to be some information missing so I can’t see the end result. I did notice that you were using Reduce to get the triples which in my view is very slow, so I have taken the liberty of amending my method of producing PPTs to produce what I think was the desired output of your notebook.

pyths[x_Integer, max_Integer] := (t = Select[Divisors[x^2], # <= x &];
   m = Sort[
    Select[(x^2 - t^2)/(2 t), 
     IntegerQ[#] && # > x && Sqrt[x^2 + #^2] <= max && 
       GCD[x, #] == 1 &]]; 
  Table[{x, m[[i]], Sqrt[x^2 + m[[i]]^2]}, {i, 1, Length[m]}])

t1 = Flatten[Table[pyths[i, 1720], {i, 3, 1720}], 1];

t1 // Map[Most] // 
 ListPlot[{#, Map[Reverse, #]}, AspectRatio -> 1, ImageSize -> 600, 
   PlotStyle -> {Red, Black}] &

On my pc if they were all computed together runs in 270ms. Maybe this helps you.

10

Paul, You have to insert the k value you wish to compute from the OEIS A096033 sequence. That’s why I have all of those d- values listed in the s1 and s2 ListPlots. It’s a very tedious technique, but I was trying to explain where all of the curves came from in the final graph, see my graph above.
See also: On the Curved Patterns Seen in the Graph of PPTs, arXiv 2104.09449v5.

11

Paul,
I forgot to mention, I’ve already done the hard work on this notebook, just run this one, the long version, it only takes a few minutes at most:
https://www.notebookarchive.org/ppt-graph-nb--2021-06-6y23baq/

JP

12

James, Thanks for the link, it does run now. Hope you don’t mind but I have taken the liberty of amending my previous code slightly that when run, ‘a few ms’ does what I think is essentially what your program is doing.

pyths[x_Integer, max_Integer] := (t = Select[Divisors[x^2], # <= x &];
   m = Sort[
    Select[(x^2 - t^2)/(2 t), 
     IntegerQ[#] && # > x && # <= max && GCD[x, #] == 1 &]]; 
  Table[{x, m[[i]], Sqrt[x^2 + m[[i]]^2]}, {i, 1, Length[m]}]); t1 = 
 Flatten[Table[pyths[i, 1720], {i, 3, 1720}], 1]; 
t1 // Map[Most] // 
 ListPlot[{#, Map[Reverse, #]}, AspectRatio -> 1, ImageSize -> 600, 
   PlotStyle -> {Red, Black}] &

and to see the individual plots as in your notebook.

s1 = t1 // Map[Most] // 
  ListPlot[#, AspectRatio -> 1, ImageSize -> 600, PlotStyle -> Red] &

s2 = t1 // Map[Most] // 
  ListPlot[Map[Reverse, #], AspectRatio -> 1, ImageSize -> 600, 
    PlotStyle -> Black] &

Show[{s1, s2}, PlotRange -> All]

PC.

13

Thanks,
JP