Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

In my demonstration "Sequence Sums That Are Squares" I demonstrate two "lines" of solutions (of infinite length) and ask whether someone can find one more line.

I am looking forward to your solution. I did not find a third line of solutions.

share|improve this question
2  
Dear Karl, welcome to Mathematica.SE! The reason your "question" has been down voted by others is that it isn't really posed as a question. It would also be good to add some more information. I have added a link to the demonstration, but it might be good to show some more workings on what you tried to find more lines. Some code would really help. I'm not going to close your question just yet, but please come back and edit it, or else we will have to close it as not a real question. –  Verbeia Jan 16 at 10:19

1 Answer 1

What you have found are not lines of infinite length, unless you can prove that they are, by induction e.g.

What I want to show is still not a proof for anything but a solution, not great but works, how to find more such lines.

Let generate the data

k = 300;
l = Reap[Do[If[IntegerQ[Sqrt[1/2 (1 + m - n) (m + n)]], Sow@{n, m}], 
            {n, k}, {m, n + 1, k}]
        ][[ 2, 1]];
(*and a subset where coordinates are less than z*)
z = 70;
set = Select[l, #[[ 1]] < z && #[[ 2]] < z &];
(*now we are generating a set of vectors pointing between each pair of `set`.*)
(*and then we are deleting duplicates etc. we want to vy>wx, otherwise it can;t be infinite*)
v = (Sort /@ 
      GatherBy[
         Select[#2 - # & @@@ Subsets[set, {2}],
                #[[ 1]] < #[[ 2]] && #[[ 1]] > 0 && #[[ 2]] > 0 &], #[[ 2]]/#[[ 1]] &
        ]
    )[[ ;; , 1]];

(*looking for euch points (x) that x+v and x+2v and so on withing the range*)
(*are members of l *)
lines = GatherBy[
           Reap[
               Do[
                  Scan[
                       With[{max = Floor@Min[(300 - set[[ i]])/#]}, 
                        If[Length[Complement[Table[set[[i]] + k #, {k, max}], l]] == 0, 
                           Sow[{set[[ i]], #, max}]]
                          ] &,
                      v]
                 , {i, 1, Length@set}]
               ][[ 2, 1]]
               , #[[ 2]] &][[ ;; , 1]]

Ok, it seems there are more than one:

ListPlot[l, AspectRatio -> 1, ImageSize -> 1000, GridLines -> {Automatic, Automatic},  
            Frame -> True, PlotStyle -> {AbsolutePointSize@10, GrayLevel@.5}, 
            Epilog -> {{Hue@RandomReal[], Dashed, Line[{#, # + 200 #2}], 
                       AbsolutePointSize@5, 
                       Point[Table[# + i #2, {i, 0, #3}]]} & @@@ lines},
            Background -> Black]

enter image description here

share|improve this answer

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

Not the answer you're looking for? Browse other questions tagged or ask your own question.