0. 胞の座標を作成するプログラム

Clear["Global`*"]

cellA[x_List]:=(
mixed:=Partition[Riffle[x,{0,0,0,0}],2];
combi={{1,1,2,2},{2,2,1,1},{1,2,1,2},{2,1,2,1},{1,2,2,1},{2,1,1,2}};
Table[Table[mixed[[i,combi[[k,i]]]],{i,1,4}],{k,1,6}])

c1221=cellA[{1,-1,-1,1}];c1221

cellB[x_List]:=(pos:=Position[x,0];
Flatten[Table[{ReplacePart[x,k->1],ReplacePart[x,k->-1]},{k,pos}],1]);

cY1=cellB[{0,1,0,0}];cY1

c1111=cellA[{1,1,1,1}];c1112=cellA[{1,1,1,-1}];c1121=cellA[{1,1,-1,1}];
c1122=cellA[{1,1,-1,-1}];c1211=cellA[{1,-1,1,1}];c1212=cellA[{1,-1,1,-1}];
c1221=cellA[{1,-1,-1,1}];c1222=cellA[{1,-1,-1,-1}];c2111=cellA[{-1,1,1,1}];
c2112=cellA[{-1,1,1,-1}];c2121=cellA[{-1,1,-1,1}];c2122=cellA[{-1,1,-1,-1}];
c2211=cellA[{-1,-1,1,1}];c2212=cellA[{-1,-1,1,-1}];c2221=cellA[{-1,-1,-1,1}];
c2222=cellA[{-1,-1,-1,-1}];
cX1=cellB[{1,0,0,0}];cY1=cellB[{0,1,0,0}];cZ1=cellB[{0,0,1,0}];cU1=cellB[{0,0,0,1}];cX2=cellB[{-1,0,0,0}];cY2=cellB[{0,-1,0,0}];cZ2=cellB[{0,0,-1,0}];cU2=cellB[{0,0,0,-1}];

cells={c1111,c1112,c1121,c1122,c1211,c1212,c1221,c1222,
c2111,c2112,c2121,c2122,c2211,c2212,c2221,c2222,cX1,cY1,cZ1,cU1,cX2,cY2,cZ2,cU2};

1.  cells を 1つのスレッドでつなげるタイプ(snake型)のデータ作成

1-1. mycells[[k]]とmycells[[k+1]]が共通の平面を持つ様に並べ替える．

cells={c1111,c1112,c1121,c1122,c1211,c1212,c1221,c1222,
c2111,c2112,c2121,c2122,c2211,c2212,c2221,c2222,cX1,cY1,cZ1,cU1,cX2,cY2,cZ2,cU2};
mycells0={cU2};
cells0=Complement[cells,mycells0];


While[Length[cells]>0,
Catch[
mycells=mycells0;
cells=cells0;
Do[(
nextset=Select[cells,Length[Intersection[Last[mycells],#]]==3&];
If[nextset=={},Throw["sippai"]];
next=RandomChoice[nextset];
(*next=mysort[Last[mycells],next0];*)
AppendTo[mycells,next];
cells=Complement[cells,{next}];)
,{24}]
]
]

1 - 2. mycells[[k + 1]] の，共通な三点が　mycells[[k]] の対応する3点の真下に来るように 「mysort[a, b]」 を使う．

change1and2[{x_,y_}]:={x,3-y};
change1and2[{{x_,y_}}]:={x,3-y};

mysort[x_,y_]:=(
co=Intersection[x,y];
x1=Partition[x,2];
y1=Partition[y,2];
Flatten[ReplacePart[x1,{change1and2[Position[x1,co[[1]]]]->Extract[y1,change1and2[Position[y1,co[[1]]]]],
change1and2[Position[x1,co[[2]]]]->Extract[y1,change1and2[Position[y1,co[[2]]]]],
change1and2[Position[x1,co[[3]]]]->Extract[y1,change1and2[Position[y1,co[[3]]]]]}
 ],1])

(*example*)
Clear[p,q,r,s,t,u];
a={p,q,r,s,t,u};
b={r,3,2,t,1,p};
mysort[a,b];

mycellsSorted={mycells[[1]]}
Do[AppendTo[mycellsSorted,mysort[mycellsSorted[[k]],mycells[[k+1]]]],{k,23}]
mycells=mycellsSorted;

1-3. mycells[[k]]のmycells[[k+1]]との共通な三点の位置を nums で定義する.
当然 nums[i]とnums[i+1]は必ず異なる．

nums=Table[Sort[Flatten[Table[Position[mycells[[j]],(Intersection[mycells[[j]],mycells[[j+1]]])[[i]]],{i,1,3}]]],{j,1,23}];

2.  3次元空間内で 正8面体を重ねる(snake type)

proj[mode_Integer,x_List]:=Switch[mode,
1,Table[Drop[x[[k]],{4}],{k,1,Length[x]}],
2,Table[Drop[x[[k]],{3}],{k,1,Length[x]}],
3,Table[1/(x[[k,4]]) Drop[x[[k]],{4}],{k,1,Length[x]}]
];

poly0:=proj[1,mycells[[1]]];


octahedron[vecs_]:=(pvecs:=Partition[vecs,2];
Table[Table[Table[Polygon[{pvecs[[1,i]],pvecs[[2,j]],pvecs[[3,k]]}],{k,1,2}],{j,1,2}],{i,1,2}]);


nextpoly[vecs_,num_]:=(
range=Range[6];
cnum=Complement[range,num];
common=Part[vecs,num];
hanare=Part[vecs,cnum];
shiftvec=2/3 (Total[common]-Total[hanare]);
hanare'=Map[#+shiftvec&,hanare];
ReplacePart[vecs,{cnum[[1]]->hanare'[[1]],cnum[[2]]->hanare'[[2]],cnum[[3]]->hanare'[[3]]}]
);


poly={poly0};
Do[AppendTo[poly,nextpoly[Last[poly],nums[[k]]]],{k,23}];

(*x,y,z range*)
Xcords=Flatten[poly,1][[All,1]];
Ycords=Flatten[poly,1][[All,2]];
Zcords=Flatten[poly,1][[All,3]];
{Mx,mx}={Max[Xcords],Min[Xcords]};
{My,my}={Max[Ycords],Min[Ycords]};
{Mz,mz}={Max[Zcords],Min[Zcords]};
myrange={{mx,Mx},{my,My},{mz,Mz}};

ABCDEFGH={Blue,octahedron[poly0]};
snake=Map[octahedron,poly];

(*show*)
Manipulate[Graphics3D[{ABCDEFGH,Opacity[0.8],Take[snake,k]},PlotRange->myrange,Boxed->False],{k,1,24,1}]

3. 外側の胞(cU1, cU2など)の側面と同じ面で繋がっていたら，新しいスレッドを作るタイプ(octopus型)のデータ(myDcells&Dnums)作成

(*myDcells doesn't include the start cell such as cU2 or cU1.*)

surfaces=Select[mycells,Length[Intersection[mycells0[[1]],#]]==3&];
sikiri=Table[Position[mycells,surfaces[[k]] ],{k,1,8}]//Flatten;
AppendTo[sikiri,25];
myDcells=Table[Take[mycells,{sikiri[[i]],sikiri[[i+1]]-1}],{i,1,8}];
DnumsOfsikiri=Table[Sort[Flatten[Table[Position[mycells[[1]],Intersection[mycells[[1]],mycells[[sikiri[[i]]]]][[k]]],{k,1,3}]]],{i,1,8}];
Dnums=Table[
Prepend[Take[nums,{sikiri[[i]],sikiri[[i+1]]-2}],DnumsOfsikiri[[i]]],{i,1,8}];
nums;
mycells;

4.  3次元空間内で 正8面体を重ねる(octopus type)

poly0=proj[1,mycells[[1]]];

Dpoly={poly0};
Do[
(AppendTo[Dpoly,nextpoly[poly0,Dnums[[k,1]]]];
If[Length[Dnums[[k]]]>1,Do[AppendTo[Dpoly,nextpoly[Last[Dpoly],Dnums[[k,j]]]],
{j,2,Length[Dnums[[k]]]}]]
)
,{k,8}];

(*x,y,z range*)
DXcords=Flatten[Dpoly,1][[All,1]];
DYcords=Flatten[Dpoly,1][[All,2]];
DZcords=Flatten[Dpoly,1][[All,3]];
{DMx,Dmx}={Max[DXcords],Min[DXcords]};
{DMy,Dmy}={Max[DYcords],Min[DYcords]};
{DMz,Dmz}={Max[DZcords],Min[DZcords]};
Dmyrange={{Dmx,DMx},{Dmy,DMy},{Dmz,DMz}};

octopus=Map[octahedron,Dpoly];
Manipulate[Graphics3D[{{Blue,ABCDEFGH},Opacity[0.6],Take[octopus,k]},PlotRange->Dmyrange,Boxed->False],{k,1,24,1}]