Pensieve header: An attempt to “mine” all the diamonds within an Extraction Graph. Fails because the notion of a diamond is not entirely well-defined, as in ExtranctionGraph[BR[3,{-1,-2,-2,-2,-1}]].

SetDirectory@"C:\\drorbn\\AcademicPensieve\\Projects\\OU";
<< "OU-Programs.m"

MineDiamonds[𝒪_]:=Module[{vd,n,gs,vs,p,m1,m2,g,q,k, c,cs (* children *), pds (* pure descendents *), ds,diamonds},
gs=VPBGenerators[n=Count[vd=(OverBar[Γ])[𝒪],_EOS]];
vs={vd}; cs={{}}; p=0;
While[p<Length[vs],
m1=Count[vd=vs[[++p]],(Subscript[X, _])[_,_]];
Do[
m2=Count[q=(OverBar[Γ])[VD[VPB[n,g/.{σ->(OverBar[σ]),(OverBar[σ])->σ}]]**vd],(Subscript[X, _])[_,_]];
If[m2<m1,
If[!MemberQ[vs,q],AppendTo[vs,q]; AppendTo[cs,{}]];
k=Position[vs,q][[1,1]];
cs[[p]]=cs[[p]]⋃{g->k};
],
{g,gs}
]
];
pds=Table[{},p];diamonds={};
Do[
ds=SortBy[Last]@Flatten@Table[
{{c[[1]]}->(c[[2]])}⋃((Prepend[#[[1]],c[[1]]]->(#[[2]]))&/@pds[[c[[2]]]]),
{c,cs[[k]]}];
ds=GatherBy[ds,Last];
ds=If[Length[#]==1,#,
diamonds=Join[diamonds,Prepend[k]/@Diamond@@@Subsets[First/@#,{2}]]; {}
]&/@ds;
pds[[k]]=Join@@ds;
Print[{k,pds[[k]]}],
{k,OrderingBy[vs,Length]}
];
Sort@diamonds
]

MineDiamonds[BR[3,{-1,-2,-2,-2,-1}]]//Column

BR[3,{-1,-2,-2,-2,-1}]//ExtractionGraph

The above OU tangle is probably:

BR[3,{-1,-2,-2,-2,-1}]//ExtractionGraph//PlanarGraphQ

BR[3,{-1,-2,-2,-1}]//ExtractionGraph

BR[3,{-1,-2,-2,-1}]//ExtractionGraph//PlanarGraphQ

BR[3,{-1,-2,-1}]//ExtractionGraph

BR[3,{-1,-2,-1}]//ExtractionGraph//PlanarGraphQ

ExtractionGraph /@ {BR[3,{2,1,1,1,1}], BR[3,{2,1,1,1,1,1}],BR[3,{-1,2,2,2,2}], BR[3,{-1,2,2,2,2,2}],BR[3,{-1,2,2,2,2,1}], BR[3,{-1,2,2,2,2,2,1}], BR[3,{2,1,1,1,1,1,1,1,-2}]}

BR[3,{1,2,1,1,2,1}]//ExtractionGraph

BR[3,{1,2,1,1,2,1,1,2,1}]//ExtractionGraph

BR[4,{3,1,2,1,1,2,1,1,2,1,-3}]//ExtractionGraph//PlanarGraphQ

BR[4,{3,1,2,1,1,2,1,1,2,1,-3}]//ExtractionGraph

BR[4,{3,1,2,1,1,2,1,1,2,1}]//ExtractionGraph//PlanarGraphQ

BR[4,{3,1,2,1,1,2,1,1,2,1}]//ExtractionGraph

BR[4,{1,2,3,1,2,1}]//ExtractionGraph

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1}]]//PlanarGraphQ

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1}], GraphLayout->"SpringElectricalEmbedding"]

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}]]//PlanarGraphQ

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}], GraphLayout->"SpringElectricalEmbedding"]

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}]]//PlanarGraphQ

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}], GraphLayout->"SpringElectricalEmbedding"]

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}]]//PlanarGraphQ

ExtractionGraph[BR[4,{1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1,1,2,3,1,2,1}], GraphLayout->"SpringElectricalEmbedding"]