# How to make my code to generate polytopes more efficient?

The main purpose of my code is to generate polytopes by starting with a point. With this point, I then apply 3 actions which generates at most 3 others points:

pi1[a_, b_, c_] := {a, b, c} - a*cartm[[1]];
pi2[a_, b_, c_] := {a, b, c} - b*cartm[[2]];
pi3[a_, b_, c_] := {a, b, c} - c*cartm[[3]];
picomb[a_, b_, c_] := Prepend[List[pi1[a, b, c], pi2[a, b, c], pi3[a, b, c]], {a, b, c}];


where

 cartm = {{2, -1, 0}, {-1, 2, -1}, {0, -1, 2}};


From now on, I am willing to apply those 3 exact actions on the new list of the 4 possible points. In fact, I want to act those 3 actions on every new list generated until the length of the previous one is equal to the new one generated. But, I only made it possible by using brute force technique:

    orb1[list_] :=
DeleteDuplicates@
Partition[
Flatten@Table[
picomb@picomb[list][[i]], {i, 1, Length@picomb[list]}], 3];
orb2[list_] :=
With[{liste = orb1[list]},
DeleteDuplicates@
Partition[Flatten@Table[picomb@liste[[i]], {i, 1, Length@liste}],
3]];
orb3[list_] :=
With[{liste = orb2[list]},
DeleteDuplicates@
Partition[Flatten@Table[picomb@liste[[i]], {i, 1, Length@liste}],
3]];


and so on, until the 3 actions no longer affect the list.

Maybe you will find this a bit more elegant:

ClearAll[F, f];
M = DeveloperToPackedArray[{{2, -1, 0}, {-1, 2, -1}, {0, -1, 2}}];
f[x_?VectorQ] := KroneckerProduct[{1, 1, 1}, x] - x M;
F[list_?MatrixQ] := Union[list, Union @@ (f /@ list)];
DoItAll[a_, b_, c_] := FixedPoint[F, DeveloperToPackedArray[{{a, b, c}}]]


Usage example:

DoItAll[1, 2, 3] == Union @@ (orb2 @@@ orb2[1, 2, 3])


True

• Thank you for your answer, I really appreciate your time, but it is too complicated for me. Plus, I wished I could have stick to something similar to the original code or use a function such as NestWhileList. Jul 2, 2019 at 20:07
• Amazing simplification of the original code ! Jul 2, 2019 at 20:42
• I totally agree with you. His code is way simpler than mine. The point is that I only want to work on the part where it generates new points without having to brute force like it just like I did. Jul 2, 2019 at 21:03
• @LilGreg For your info: f is the part that generates the new point. F maps f over all preexistent points and unites them with the newly generated points. FixedPoint is a basically a NestWhile that stops when nothing changes any more. So this is essentially what you asked for. Jul 3, 2019 at 20:24

It is not as elegant as the previous answer, but it does a great job:

pi[list_] := list - list[[#]]*cartm[[#]] & /@ {1, 2, 3};

orbit[list_] :=
Module[{listGraph, listeTemp, i, j}, listGraph = {};
listeTemp = list;
For[i = 1, i <= Length[listeTemp], i++,
If[MemberQ[listGraph, listeTemp[[i]]], Null,
AppendTo[listGraph, listeTemp[[i]]];
listGraph = Partition[Flatten@listGraph, 3];
AppendTo[listeTemp, pi[listeTemp[[i]]]];
listeTemp = Partition[Flatten@listeTemp, 3]]];
Table[listGraph[[j]][[1]]*w1 + listGraph[[j]][[2]]*w2 +
listGraph[[j]][[3]]*w3, {j, 1, Length@listGraph}]];