4
$\begingroup$

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.

$\endgroup$

2 Answers 2

6
$\begingroup$

Maybe you will find this a bit more elegant:

ClearAll[F, f];
M = Developer`ToPackedArray[{{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, Developer`ToPackedArray[{{a, b, c}}]]

Usage example:

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

True

$\endgroup$
4
  • $\begingroup$ 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. $\endgroup$
    – LilGreg
    Jul 2, 2019 at 20:07
  • 1
    $\begingroup$ Amazing simplification of the original code ! $\endgroup$
    – yarchik
    Jul 2, 2019 at 20:42
  • $\begingroup$ 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. $\endgroup$
    – LilGreg
    Jul 2, 2019 at 21:03
  • 1
    $\begingroup$ @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. $\endgroup$ Jul 3, 2019 at 20:24
0
$\begingroup$

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}]];
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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