Wolfram Cloud Document

WOLFRAM NOTEBOOK

(* some functions to support the transformation *)norm[vec_] := N[Sqrt[vec . vec]]bumpup[{{a_, b_, c_}, loc_}] := (# / Sqrt[norm[#]] &) [ Cross[edgeloc[a] - edgeloc[c], edgeloc[b] - edgeloc[c]] ]Cross[{a_, b_, c_}, {d_, e_, f_}] := {b f - c e, c d - a f, a e - b d}edgeloc[n_] := .5 Plus @@ Cases[grverts, {{___, n, ___}, loc_} :> loc]splitedge[n_] := grverts = Join[DeleteCases[grverts, {{___, n, ___}, _}], Module[{pair = Cases[grverts, {{___, n, ___}, _}], v1, v2, e1, e2, e3, e4, e5, enum = 3 / 2 Length[grverts]}, {v1, v2} = pair; While[v1[[1,1]] != n, v1 = {RotateRight[First[v1]], Last[v1]}]; While[v2[[1,1]] != n, v2 = {RotateRight[First[v2]], Last[v2]}]; {e3, e2, e1} = First[v1]; {e3, e4, e5} = First[v2]; (* here are the new verts *); { {{e1, e3, enum+1}, .75 edgeloc[e1] + .25 edgeloc[e4] + .5 bumpup[v1]}, {{e2, enum+1, enum+2}, .75 edgeloc[e2] + .25 edgeloc[e5] + .5 bumpup[v1]}, {{e3, e4, enum+3}, .75 edgeloc[e4] + .25 edgeloc[e1] + .5 bumpup[v2]}, {{e5, enum+2, enum+3}, .75 edgeloc[e5] + .25 edgeloc[e2] + .5 bumpup[v2]} } ] ](* now we start growing from a cube, just to see what happens *)grverts = { (* cube *) {{1, 5, 4}, {0, 1, 1}}, {{2, 6, 1}, {1, 1, 1}}, {{3, 7, 2}, {1, 0, 1}}, {{4, 8, 3}, {0, 0, 1}}, {{5, 9, 12}, {0, 1, 0}}, {{6, 10, 9}, {1, 1, 0}}, {{7, 11, 10}, {1, 0, 0}}, {{8, 12, 11}, {0, 0, 0}} };grpic := Show[Graphics3D[{PointSize[.02], Point[Last[#]]& /@ grverts, Line[Cases[grverts, {{___, #, ___}, loc_} :> loc]] & /@ Union[Flatten[First /@ grverts]] }], PlotRange -> ({{-1, 1}, {-1, 1}, {-1, 1}} + .5) * 1.5]randgrvert := Random[Integer, {1, 3 / 2 Length[grverts]}]Do[grpic; splitedge[randgrvert];, {30}](* now we make a hex plane with border (difficult) and try it on that *)order = 5;grverts = Module[{outer, inner, this, loc, fout, fin, ord, ans}, ans = {}; ord = order; fout = {0, 2, 0}; fin = {-Sqrt[3] // N, 1, 0}; loc = {0, 0, 0}; this = 1; inner = 6 ord + 1; Do[Do[ AppendTo[ans, {{this - 1 /. 0 -> 6 ord, inner, this}, loc}]; loc += fout + fin; this++; inner++; , {ord}]; {fout, fin} = {fin, fin - fout}; loc += fin; , {6}]; loc += fin - fout; outer = 6 ord + 1; this = 12 ord + 1; inner = 24 ord - 5; Do[Do[ If[i==1, AppendTo[ans, {{inner - 1, outer, this}, loc}], AppendTo[ans, {{this - 1, outer, this}, loc}]]; loc += fin; this++; outer++; Do[ AppendTo[ans, {{this, inner, this - 1}, loc}]; loc += fout; this++; inner++; AppendTo[ans, {{outer, this, this - 1}, loc}]; loc += fin; this++; outer++; , {k - 1}]; {fout, fin} = {fin, fin - fout}; , {i, 6}]; loc += 2 fin - fout; outer = this; this = inner; inner = this + 6 (2 k - 3); , {k, ord, 1, -1}]; ans];grpic := Show[Graphics3D[{PointSize[.01], Point[magz[Last[#]]]& /@ grverts, Line[Cases[grverts, {{___, #, ___}, loc_} :> magz[loc]]] & /@ Union[Flatten[First /@ grverts]] }], PlotRange->All]magz[{x_, y_, z_}] := {x, y, 3 z}randgrvert := Max[ (* to prefer high numbered edges *) Random[Integer, {order 12 + 1, 3 / 2 Length[grverts]}], Random[Integer, {order 12 + 1, 3 / 2 Length[grverts]}] ]Do[splitedge[randgrvert], {40}] // TiminggrpicShow[%, ViewPoint->{0,0,50}]

SetDelayed::write:
Tag Cross in Cross[{a_, b_, c_}, {d_, e_, f_}]
is Protected.

$Failed

{32.9667 Second, Null}

-Graphics3D-

You are using a browser not supported by the Wolfram Cloud

Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.

I understand and wish to continue anyway »