(*  File is available at
    http://www.us.edu.pl/~gluza/planarity

   In case of use, please, refer to 
   "Some Remarks on Non-planar Feynman Diagrams",
 K. Bielas, I. Dubovyk, J. Gluza, T. Riemann,
 Published in Acta Phys.Polon. B44 (2013) 11, 2249, 
   arXiv:1312.5603 [hep-ph]
*)

(**---------------------------------------------------------------**)
(**                         Planarity Test                        **)
(**---------------------------------------------------------------**)

Print["by E. Dubovyk and K. Bielas ver: 1.0\ncreated: December 2013\nlast executed: ",
      Apply[Dot,If[StringLength[#]==1,"0"<>#,#]& /@ 
        Map[ToString[#]&,Reverse[Take[Date[],3]]]],
      " at ",
      Apply[StringJoin,Insert[(If[StringLength[#]==1,"0"<>#,#]& /@ 
        Map[ToString[#]&,Take[Date[],{4,5}]]),":",2]] ]

(******************************************************************************************)      

BeginPackage["PlanarityTest`"]

Needs["AMBRE`"];

PlanarityTest::usage = "PlanarityTest[{propagators},{internal_momenta}] is a function for input integrals"

(*Begin["`Private`"]*)

(******************************************************************************************)
(***********************************************)
(*               Functions                     *)
(***********************************************)
SFblue[x_]       := StyleForm[x, FontColor -> RGBColor[0, 0, 1]];
SFred[x_]        := StyleForm[x, FontColor -> RGBColor[1, 0, 0]];

(******************************************************************************************)
(***********************************************)
(*                  Main                       *)
(***********************************************)
PlanarityTest[integral_, momentas_, OptionsPattern[{DrawGraph -> False, PrintResult->True, TestAlgorithm -> 1, VertexLegNum -> 4}]] :=
Module[
{result},

If[OptionValue[TestAlgorithm] == 1,
   {result = Catch[PlTest[integral, momentas, DrGr -> OptionValue[DrawGraph], 
                                              PrRes -> OptionValue[PrintResult], Vr -> OptionValue[VertexLegNum]]];
    If[result == "error", 
       {Print[SFred["ERROR. input diagram cannot be analysed and/or drawn using Method I.\n"],
              SFblue["please try Method II without drawing option and/or with option VertexLegNum -> 5"]];
        result = Null}]},
   {result = Catch[DualVr[integral, momentas, DrGrDV -> OptionValue[DrawGraph], 
                                              PrResDV -> OptionValue[PrintResult], VrDV -> OptionValue[VertexLegNum]]];
    If[result == "error", 
       {Print[SFred["ERROR. input diagram cannot be drawn using Method I.\n"],
              SFblue["please try Method II without drawing option and/or with option VertexLegNum -> 5"]];
        result = Null}]}
];

Return[result];
];

(********************************************************************************)
(********************************************************************************)
(*                       Laplacian matrix method by E. Dubovyk                  *)
(********************************************************************************)
(********************************************************************************)
PlTest[integral_, momentas_, OptionsPattern[{DrGr->False, PrRes->True, Vr->4}]] :=
Module[
{internalmom, externalmom, qlist, xlist, nvertex, Lmatrix, Amatrix, 
 Amatrixtest, exvr, exvr4, invr, invr4, DLE, DLE4, DLI, DLI4, Vlist, Glist, rslt},

internalmom = momentas;
qlist       = (List @@ First[integral]) /. PR[q_,__,__] -> q;
xlist       = Table[x[i],{i,1,Length[qlist]}];
masslist    = (List @@ First[integral]) /. PR[__,m_,__] -> m;
nvertex     = Length[xlist] - Length[internalmom] + 1;
Lmatrix     = Table[0,{i,1,nvertex},{j,1,nvertex}];
Glist       = Table[0,{i,1,nvertex}];

(*defining of external momentas*)
externalmom = Complement[qlist /. Plus->List /. -1->1 // Flatten // DeleteDuplicates, internalmom];
externalmom = Append[externalmom, - Plus @@ externalmom]; 
(*for tadpoles -->>*) If[externalmom == {0}, externalmom = {}]; 

Vlist = Table[{},{i,1,Length[externalmom]}];
    
(*diagonal matrix elements*)
ls = Table[i,{i,1,Length[qlist]}];
    
(*diagonal matrix elements for "external" vertices*)
DLE = {};
exvr3 = Subsets[ls,{2}];
Do[
   Do[{l1 = Tuples[{"+", "-"}, 2];
       l2 = Table[qlist[[exvr3[[i]][[idx]]]],{idx,1,2}];
       CheckVer = Equal[#, externalmom[[k]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or;
       If[CheckVer,
          {DLE = Append[DLE, x[exvr3[[i]][[1]]] + x[exvr3[[i]][[2]]] ];
           Vlist[[k]] = Append[Vlist[[k]], x[exvr3[[i]][[1]]] + x[exvr3[[i]][[2]]] ];}
         ]},
      {k,1,Length[externalmom]}
     ],
   {i,1,Length[exvr3]}
];
DLE = DeleteDuplicates[DLE];
    
exvr4 = Subsets[ls,{3}];
DLE4 = {};
Do[
   Do[{l1 = Tuples[{"+", "-"}, 3];
       l2 = Table[qlist[[exvr4[[i]][[idx]]]],{idx,1,3}];
       CheckVer = Equal[#, externalmom[[k]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or;
       If[CheckVer,
          {DLE4 = Append[DLE4, x[exvr4[[i]][[1]]] + x[exvr4[[i]][[2]]] + x[exvr4[[i]][[3]]] ];
           Vlist[[k]] = Append[Vlist[[k]], x[exvr4[[i]][[1]]] + x[exvr4[[i]][[2]]] + x[exvr4[[i]][[3]]] ];}
         ]},
      {k,1,Length[externalmom]}
     ],
   {i,1,Length[exvr4]}
];
  
DLE5 = {};
If[ OptionValue[Vr] == 5,
(*******************************************************************)
{exvr5 = Subsets[ls,{4}];
Do[
   Do[{l1 = Tuples[{"+", "-"}, 4];
       l2 = Table[qlist[[exvr5[[i]][[idx]]]],{idx,1,4}];
       CheckVer = Equal[#, externalmom[[k]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or;
       If[CheckVer,
          {DLE5 = Append[DLE5, x[exvr5[[i]][[1]]] + x[exvr5[[i]][[2]]] + x[exvr5[[i]][[3]]] +  x[exvr5[[i]][[4]]] ];
           Vlist[[k]] = Append[Vlist[[k]], x[exvr5[[i]][[1]]] + x[exvr5[[i]][[2]]] + x[exvr5[[i]][[3]]] +  x[exvr5[[i]][[4]]] ];}
         ]},
      {k,1,Length[externalmom]}
     ],
   {i,1,Length[exvr5]}
];}
(*******************************************************************)
];

partdle = Subsets[Join[DLE,DLE4,DLE5],{Length[externalmom]}];
	
(*diagonal matrix elements for "internal" vertices*)
invr = Subsets[ls,{3}];
DLI = {};
Do[{l1 = Tuples[{"+", "-"}, 2];
    l2 = Table[qlist[[invr[[i]][[idx]]]],{idx,1,2}];
    CheckVer = Equal[#, qlist[[invr[[i]][[3]]]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or;
    If[CheckVer,
       {DLI = Append[DLI, x[invr[[i]][[1]]] + x[invr[[i]][[2]]] + x[invr[[i]][[3]]] ]}
      ]},
   {i,1,Length[invr]}
]; 
    
invr4 = Subsets[ls,{4}];
DLI4 = {};
Do[{l1 = Tuples[{"+", "-"}, 3];
    l2 = Table[qlist[[invr4[[i]][[idx]]]],{idx,1,3}];
    CheckVer = Equal[#, qlist[[invr4[[i]][[4]]]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or;
    If[CheckVer,
       {DLI4 = Append[DLI4, x[invr4[[i]][[1]]] + x[invr4[[i]][[2]]] + x[invr4[[i]][[3]]] + x[invr4[[i]][[4]]] ]}
      ]},
   {i,1,Length[invr4]}
];
    
DLI5 = {};
If[ OptionValue[Vr] == 5,
(*******************************************************************)
{invr5 = Subsets[ls,{5}];
Do[{l1 = Tuples[{"+", "-"}, 4];
    l2 = Table[qlist[[invr5[[i]][[idx]]]],{idx,1,4}];
    CheckVer = Equal[#, qlist[[invr5[[i]][[5]]]]] & /@ (Plus @@ # & /@ (l2*# & /@ l1 // ToString // ToExpression)) /. List -> Or; 
    If[CheckVer,
       {DLI5 = Append[DLI5, x[invr5[[i]][[1]]] + x[invr5[[i]][[2]]] + x[invr5[[i]][[3]]] +  x[invr5[[i]][[4]]] +  x[invr5[[i]][[5]]] ];}
      ]},  
   {i,1,Length[invr5]}
];}
(*******************************************************************)
];

(*two vertex tadpole*)
If[Length[DLI]==1 && Length[DLI4]==0 && Length[DLI5]==0, DLI = Append[DLI,DLI[[1]]]];
If[Length[DLI]==0 && Length[DLI4]==1 && Length[DLI5]==0, DLI4 = Append[DLI4,DLI4[[1]]]];
If[Length[DLI]==0 && Length[DLI4]==0 && Length[DLI5]==1, DLI5 = Append[DLI5,DLI5[[1]]]];   

partdli = Subsets[Join[DLI,DLI4,DLI5],{nvertex - Length[externalmom]}]; 
     
Off[General::compat];
Needs["Combinatorica`"];
Needs["GraphUtilities`"];

Do[
   Do[
      {Llist = Join[partdle[[j]],partdli[[i]]]; 
		   temp = List @@ Plus @@ Llist /. x[_] -> 1 // DeleteDuplicates;
       If[Length[temp] == 1 && First[temp] == 2, 
          {Lmatrix     = Table[0,{i,1,nvertex},{j,1,nvertex}]; 
           Do[Glist[[k]] = Lmatrix[[k]][[k]] = Llist[[k]], {k,1,nvertex}]; 
           
           (*non-diagonal matrix elements*)
           Do[
              Do[
                 {li  = (List @@ Lmatrix[[i]][[i]]) /. x[n_] -> n;
                  lj  = (List @@ Lmatrix[[j]][[j]]) /. x[n_] -> n;
                  lij = Intersection[li,lj]; 
                  If[Length[lij]>0, {Do[Lmatrix[[i]][[j]] = Lmatrix[[j]][[i]] = - x[lij[[ij]]],{ij,1,Length[lij]}]}]},
                 {j,i+1,nvertex}
                ],
               {i,1,nvertex}
              ]; 
       
        (*GRAPH*)

        If[Length[externalmom] > 0,
           {Amatrix = Lmatrix /. x[_]->1 /. -1->1;
            Do[Amatrix[[i]][[i]] = 0, {i,1,nvertex}];
            Amatrixtest  = Table[0, {i,1,nvertex+1}, {j,1,nvertex+1}];
            Do[Amatrixtest[[i]][[j]] = Amatrix[[i]][[j]], {i,1,nvertex}, {j,1,nvertex}];
            Do[Amatrixtest[[i]][[nvertex+1]] = Amatrixtest[[nvertex+1]][[i]] = 1, {i,1,Length[externalmom]}]},
           {Amatrix = Lmatrix /. x[_]->1 /. -1->1;
            Do[Amatrix[[i]][[i]] = 0, {i,1,nvertex}];
            Amatrixtest = Amatrix}
          ];
          
          gtest  = System`AdjacencyGraph[Amatrixtest]; 

          If[Combinatorica`ConnectedQ[GraphUtilities`ToCombinatoricaGraph[gtest]], {Goto[end]}];
      }]},
      {i,1,Length[partdli]}
	 ],
   {j,1,Length[partdle]}
]; Label[end];

If[!MatrixQ[Amatrixtest], Throw["error"]];

rslt = Combinatorica`PlanarQ[GraphUtilities`ToCombinatoricaGraph[gtest]];

If[OptionValue[PrRes],
   {Print["The Diagram"];
    (*Print["with the Laplacian matrix"];
    Print[Lmatrix // MatrixForm];*)
    If[rslt, Print["is planar."], Print["is non-planar."]];
    If[OptionValue[DrGr], DrawDiagram[Vlist, Glist, externalmom, masslist, qlist]]},
    {If[OptionValue[DrGr], DrawDiagram[Vlist, Glist, externalmom, masslist, qlist]]}
]; 

Return[rslt]
];

(***********************************************)
(*                DrawDiagram                  *)
(***********************************************)
DrawDiagram[ExtVerL_, AllVerL_, ExtMom_, mlst_, qlst_] :=
Module[
{ExtVertexList, AllVertexList, ExtVer, gl, G},

AllVertexList = AllVerL;
ExtVer = Table[AllVertexList[[i]],{i,1,Length[ExtMom]}];
ExtVertexList = Table[{},{i,1,Length[ExtMom]}];

Do[
   Do[
      If[Intersection[ExtVerL[[i]], {ExtVer[[j]]}] != {}, 
         {ExtVertexList[[i]] = Intersection[ExtVerL[[i]], {ExtVer[[j]]}]; 
          ExtVer = Delete[ExtVer,j]; Break[]} ], 
      {j,Length[ExtVer]}
     ],
   {i,1,Length[ExtMom]} 
];
    
gl = {};
    
jlist = Table[j,{j,1,Length[ExtVertexList]}]; 
Do[
   Do[
      If[AllVertexList[[i]] == ExtVertexList[[j]][[1]], 
         {gl = Append[gl, {Rule["ex"~~ToString[i], ToString[i]], ToString[ExtMom[[j]] ]} ]; 
          jlist = DeleteCases[jlist,j]; Break[]} ], 
       {j,jlist}
      ],
   {i,1,Length[ExtMom]} 
];

AllVertexList = AllVertexList /. Plus -> List;
  
Do[
   Do[
      Do[
         Do[
            If[AllVertexList[[i]][[j]] == AllVertexList[[k]][[l]],
               gl = Append[gl, {Rule[ToString[i],ToString[k]],"["~~ToString[qlst[[AllVertexList[[i]][[j]] /. x[idx_] -> idx]]]
                                                                 ~~","~~ToString[mlst[[AllVertexList[[i]][[j]] /. x[idx_] -> idx]]]
                                                                 ~~"]"} ] ], 
             {l,1,Length[AllVertexList[[k]] ]}
            ],
          {k,i+1,Length[AllVertexList]}
         ],
       {j,1,Length[AllVertexList[[i]] ]}
      ],
    {i,1,Length[AllVertexList]-1}
];
    
gl = gl //. {rl1___, {Rule[a_, b_], s1_}, {Rule[a_, b_], s2_},rl2___} -> {rl1, {Rule[a, b], s1}, {Rule[b, a], s2}, rl2}; 
G = GraphPlot[gl,MultiedgeStyle->0.3(*,Method->SpringEmbedding*)];
Print[G];
    
(* tadpoles *)
nxlst = List@@AllVertexList // Flatten // DeleteDuplicates; 
If[Length[qlst] > Length[nxlst],
   {idxlst = Table[i,{i,1,Length[qlst]}]; nxlst = nxlst /. x[n_]->n;
    tadidx = Complement[idxlst, nxlst]; tadlst = ""; 
    Do[tadlst = tadlst~~"PR["~~ToString[qlst[[tadidx[[i]]]]]~~","~~ToString[mlst[[tadidx[[i]]]]]~~"]",{i,1,Length[tadidx]}];
    If[Length[tadidx] == 1, Print["With tadpole: ",tadlst], Print["With tadpoles: ",tadlst]];}
];

Return[]
];

(********************************************************************************)
(********************************************************************************)
(*                       Dual var method by K. Bielas                           *)
(********************************************************************************)
(********************************************************************************)

DualVr[integral_, momentas_, OptionsPattern[{DrGrDV -> False, PrResDV -> True, VrDV -> 4}]]:=

Module[{intmom,num,lum,prop,dual,propext,di,comm,mom,mom1,propext1,ylist,xs,adj,adj1,
		adjnum,adjnum1,check,ch,toext,gath,gath1,figbef,all,td,td1,td2,td3,g,tadmom,add,tad},

intmom = momentas;

lum = Length[intmom];
prop  = (List @@ Last[integral]) /. PR[q_,__,__] -> q /. c_^Integer_->c;

all=DeleteDuplicates[Flatten[prop/.Plus->List/.-c_->c]];

toext=Complement[DeleteDuplicates[Flatten[prop/.Plus->List/.-c_->c]],intmom];
num=Length[toext];

dual=Table[x[j],{j,1,num+lum+1}];

tad={};
Do[
	If[Tally[Flatten[prop/.Plus->List/.-c_->c]][[i]][[2]]==1&&FreeQ[toext,Tally[Flatten[prop/.Plus->List/.-c_->c]][[i]][[1]]],
														tad=Append[tad,Tally[Flatten[prop/.Plus->List/.-c_->c]][[i]][[1]]],Break],
{i,1,Length[Tally[Flatten[prop/.Plus->List/.-c_->c]]]}
];

Do[
	Do[
		If[StringFreeQ[Map[ToString,List @@ Last[integral]][[i]],ToString[tad[[j]]]],Break[]
    (*,{Print["tadpole"],Print[(List @@ Last[integral])[[i]]]}*)],
	{j,1,Length[tad]}
	],
{i,1,Length[prop]}
];

add=Total[toext];
If[toext!={},propext=Flatten[Append[Append[prop,toext],add]],propext=Flatten[Append[prop,toext]]];

g[y_]:={y};
td1=Union[DeleteCases[Map[g,propext/.Plus->List/.-c_->c],{{__}}],Flatten[Cases[Map[g,propext/.Plus->List/.-c_->c],{{__}}],1]];

td2=Sort@Cases[#, _List] & /@ ConnectedComponents@
  Graph[Thread@UndirectedEdge[ConstantArray[#, Length[#]], #] & /@ td1 // Flatten];

figbef[x_] := (figbef[x] = Sequence[]; x);
gath=Table[0,{i,1,Length[td2]}];
gath1=Table[0,{i,1,Length[td2]}];
td3=Table[0,{i,1,Length[td2]}];

Do[
	If[Length[td2[[i]]]>1,td3[[i]]=DeleteCases[td2[[i]],{_}],td3[[i]]=td2[[i]]],
{i,1,Length[td2]}
];

Do[
	{gath[[i]]=DeleteCases[Map[figbef, Gather[td3[[i]],#1\[Intersection]#2=!={}&][[1]], {2}],{}]},
{i,1,Length[td2]}
];

Do[
	gath1[[i]]=Append[gath[[i]]/.{gath[[i]][[1]][[1]],a__}->{a},
		Complement[Map[DeleteDuplicates[Flatten[#]]&,td2][[i]],Map[DeleteDuplicates[Flatten[#]]&,gath][[i]]]],
{i,1,Length[td2]}
];

tadmom=Table[0,{i,1,Length[td2]}];

Do[
	tadmom[[i]]=Map[Prepend[#,gath[[i]][[1]][[1]]]&,Flatten /@ Tuples[Permutations /@ gath1[[i]]]],
{i,1,Length[td2]}
];

Do[{

ch=0;

Do[{
adj=Table[0,{i,1,Length[tadmom[[o]][[m]]]},{k,1,2^i}];(*end*)
adj[[1]]={propext}/.tadmom[[o]][[m]][[1]]->dual[[1]]-dual[[2]];
adj1=Table[0,{j,1,Length[propext]}];

td=0;
di=1;

Do[
	If[i==2,{Do[
	{
	Do[
		{If[FreeQ[DeleteCases[adj[[i-1]],0][[k]][[j]],x[_]]||FreeQ[DeleteCases[adj[[i-1]],0][[k]][[j]],tadmom[[o]][[m]][[i]]],
													Break,adj1[[j]]=DeleteCases[adj[[i-1]],0][[k]][[j]]]},			
	{j,1,Length[propext]}
	],	

	ylist=Cases[Flatten[DeleteCases[adj1,0]/.Plus->List],x[_]|-x[_]],
	
	xs=DeleteDuplicates[ylist/.-c_->c],

	If[Length[xs]==2,

	{mom1=Total[Cases[Flatten[DeleteCases[adj1,0][[1]]/.Plus->List],tadmom[[o]][[m]][[i]]|-tadmom[[o]][[m]][[i]]]],
	
	adj[[i]][[k]]={adj[[di]][[k]]/.mom1->dual[[i+1]]-ylist[[1]]/.-mom1->-dual[[i+1]]+ylist[[1]],
						adj[[di]][[k]]/.mom1->dual[[i+1]]-ylist[[2]]/.-mom1->-dual[[i+1]]+ylist[[2]]}},
	Break],

	di=di+1
	},
{k,1,Length[DeleteCases[adj[[i-1]],0]]}
]},
{
	Do[
	{
	
	adj1=Table[0,{j,1,Length[propext]}];
	
	Do[
		{If[FreeQ[(Select[adj[[i-1]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]][[j]],x[_]]||
			FreeQ[(Select[adj[[i-1]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]][[j]],tadmom[[o]][[m]][[i]]],
			Break,adj1[[j]]=(Select[adj[[i-1]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]][[j]]]},
			
	{j,1,Length[propext]}
	],
	
	
	ylist=Cases[Flatten[DeleteCases[adj1,0]/.Plus->List],x[_]|-x[_]],
	
	xs=DeleteDuplicates[ylist/.-c_->c],

	comm=Total[Cases[Flatten[DeleteCases[adj1,0][[1]]/.Plus->List],Sort[Tally[ylist/.-c_->c],#1[[2]]>#2[[2]]&][[1]][[1]]|
																	-Sort[Tally[ylist/.-c_->c],#1[[2]]>#2[[2]]&][[1]][[1]]]],

	mom1=Total[Cases[Flatten[DeleteCases[adj1,0][[1]]/.Plus->List],tadmom[[o]][[m]][[i]]|-tadmom[[o]][[m]][[i]]]],
	
	If[Length[xs]==2,

	{adj[[i]][[k]]={(Select[adj[[di]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]]/.mom1->dual[[i+1]]-ylist[[1]]/.-mom1->-dual[[i+1]]+ylist[[1]],
						(Select[adj[[di]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]]/.mom1->dual[[i+1]]-ylist[[2]]/.-mom1->-dual[[i+1]]+ylist[[2]]}},

	{
					
					adj[[i]][[k]]={(Select[adj[[di]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]]/.mom1->dual[[i+1]]-comm/.-mom1->-dual[[i+1]]+comm,
										(Select[adj[[di]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[k]]/.mom1->dual[[i+1]]-comm/.-mom1->-dual[[i+1]]+comm}}]
	},
{k,1,Length[Select[adj[[i-1]], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a]}
],di=di+1}],
{i,2,Length[tadmom[[o]][[m]]]}
];

adjnum=Table[0,{i,1,Length[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)]},{j,1,Length[propext]}];
adjnum1=Table[0,{i,1,Length[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)]},{j,1,Length[propext]}];
Do[
	{Cases[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[j]],x[_]|-x[_]|x[_]+__|-x[_]+__]},
{j,1,Length[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)]}
];
check=Table[0,{i,1,Length[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)]}];
Do[
	{Do[
		
			adjnum[[i]][[j]]=Length[Cases[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)[[i]][[j]],x[_]|-x[_]|x[_]+__|-x[_]+__]],

	{j,1,Length[propext]}
	],
	adjnum1[[i]]=DeleteCases[DeleteDuplicates[adjnum[[i]]],0],
	If[Length[adjnum1[[i]]]==1,check[[i]]=1,Break]},
{i,1,Length[(Select[Last[adj], FreeQ[#, 0 | 0.] &]/.a_?MatrixQ:>Sequence@@a)]}
];

If[Total[check]>0||Length[DeleteDuplicates[Flatten[tadmom[[o]]]]]==1,{ch=ch+1},Break];

},
{m,1,Length[tadmom[[o]]]}
];

If[ch>0,Break,td=td+1];

},
{o,1,Length[tadmom]}
];

(****************************************************************************)
rslt = If[td > 0, False, True];
If[OptionValue[PrResDV],
   {Print["The Diagram"];
    If[rslt, Print["is planar."], Print["is non-planar."]];
    If[OptionValue[DrGrDV], PlTest[integral, momentas, PrRes -> False, DrGr -> True, Vr -> OptionValue[VrDV]]]},
   {If[OptionValue[DrGrDV], PlTest[integral, momentas, PrRes -> False, DrGr -> True, Vr -> OptionValue[VrDV]]]}
  ]; 

Return[rslt]
(****************************************************************************)

];

(*End[]*)

EndPackage[]
