Message Boards Message Boards

Fixing RegionMember & A302176 at once.

Posted 4 years ago
POSTED BY: Brad Klee

Optimized Code

P1 = Expand[ExpToTrig[ReIm@Exp[I 2 Pi/5 #] & /@ {0, 1, 2, 3, 4}] /. {
     Sqrt[(5/8) + Sqrt[5]/8] -> x,
     Sqrt[(5/8) - Sqrt[5]/8] -> y,
     Sqrt[5] -> 2 z - 1}];

SymRep = {z -> (1/2)*(1 + Sqrt[5]), x -> Sqrt[(5/8) + Sqrt[5]/8],  y -> Sqrt[(5/8) - Sqrt[5]/8]};
(* RootReduce[{z^2 - z - 1, 4 x^2 - 2 - z, 4 x y - 2 z + 1, y z - x,  3 - 4 y^2 - z} /. SymRep] *)

xyzSimp[poly_] := Fold[PolynomialMod, poly, 
        {4 x^2 - 2 - z, 3 - 4 y^2 - z, 4 x y - 2 z + 1, y z - x, z^2 - z - 1}]
(* xyzSimp[{z^2 - z - 1, 4 x^2 - 2 - z, 4 x y - 2 z + 1, y z - x, 3 - 4 y^2 - z}] *)

P2 = xyzSimp[Expand[-z*P1 ]];
P3 = xyzSimp[Expand[z*P1]];
P4 = -P1;

PI1[x_] := Expand[Dot[x, P1[[{1, 2, 3, 4}]]] /. SymRep]

PI2[x_] := Dot[x, P1[[{1, 3, 5, 2}]]]

SqNorms = {1, 1 + z, 1 + z, 1};

PolyP[Pent_, {x_, y_}] := Times @@ (Partition[Pent, 2, 1, 1] /. {
      {x1_, y1_}, {x2_, y2_}} :> Sign[
           xyzSimp[(y - y1) (x2 - x1) - (x - x1) (y2 - y1)] /. SymRep])

MoveStar = Append[IdentityMatrix[4], -Total[IdentityMatrix[4]]];

CheckW[pi2_, ind_] := Switch[ind,
  0, Equal[pi2 /. SymRep, {0, 0}],
  1, And[PolyP[P1, pi2] >= 0, 
   Expand[(SqNorms[[1]] - xyzSimp[pi2.pi2]) /. SymRep] >= 0 ],
  2, And[PolyP[P2, pi2] > 0, 
   Expand[(SqNorms[[2]] - xyzSimp[pi2.pi2]) /. SymRep] > 0 ],
  3, And[PolyP[P3, pi2] >= 0, 
   Expand[(SqNorms[[3]] - xyzSimp[pi2.pi2]) /. SymRep] > 0 ],
  4, And[PolyP[P4, pi2] > 0, 
   Expand[(SqNorms[[4]] - xyzSimp[pi2.pi2]) /. SymRep] > 0 ]
  ]

Iterate[set_, grow_] := {Join[set, grow],
   Select[Complement[Flatten[
      Outer[Plus, grow, Join[MoveStar, -MoveStar], 1], 1],
     set], CheckW[PI2[#], Mod[Total[#], 5]] &]};

GetLines[nInd_] := MapIndexed[Function[{a},
     Line[{PI1@data[[nInd, #2[[1]]]], 
       PI1@data[[nInd + 1, a]]}] ] /@ #1 &,
  Flatten /@ Map[Position[data[[nInd + 1]], #] &,
    Outer[Plus, data[[nInd]], Join[MoveStar, -MoveStar], 1], {2}]]

Generate Data

(* ~15 min. @ 2.7GHz *)
AbsoluteTiming[
 data = NestList[Iterate[#[[1]], #[[2]]] &, {{}, {{0, 0, 0, 0}}}, 
     100][[All, -1]];]

GraphLines = GetLines /@ Range[100];

Output

lenDat = Length /@ data
Out[]:={1, 5, 5, 20, 15, 25, 20, 45, 35, 50, 45, 45, 55, 75, 60, 65, 65, 
100, 80, 105, 95, 85, 95, 130, 115, 135, 120, 105, 135, 160, 135, 
125, 145, 185, 160, 190, 165, 145, 180, 215, 185, 165, 185, 240, 205, 
245, 220, 185, 215, 270, 240, 275, 245, 205, 255, 300, 265, 225, 260, 
325, 285, 330, 295, 245, 295, 355, 320, 360, 315, 265, 340, 385, 335, 
285, 345, 410, 365, 415, 360, 305, 385, 440, 385, 325, 385, 465, 410, 
470, 415, 345, 420, 495, 445, 500, 435, 365, 465, 525, 460, 385, 465}

Graphics[GraphLines]

NotPenroseAgain

Growth Animation

NotPenroseGrow

POSTED BY: Brad Klee
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract