(* *********************************************************** *)
(*                                                             *)
(**                  CreateTopologies.m                       **)
(*                                                             *)
(* by Hagen Eck and Sepp Kueblbeck (last change: 04/91)        *)
(*                                                             *)
(* *********************************************************** *)

BeginPackage["CreateTopologies`","FeynArts`"]

Needs["Utilities`Compare`"]

CreateTopologies::usage = "
CreateTopologies[ l , e , options ] returns a TopologyList of \n
Topologies with e external points and l loops (l=0..2). "

Tadpoles::usage = "
Tadpoles is an Option of CreateTopologies. Tadpoles->False \n
omits tadpoles. "

SelfEnergies::usage = "
SelfEnergies is an Option of CreateTopologies. \n
SelfEnergies->False omits selfenergies. "

WFCorrections::usage = "
WFCorrections is an Option of CreateTopologies. External \n
self-energies and tadpoles (wave function corrections) \n
are omitted if this option is set to False. "

Triangles::usage = "
Triangles is an Option of CreateTopologies. Triangles->False \n
omits three point functions."

Boxes::usage = "
Boxes is an Option of CreateTopologies. Boxes->False 
\n omits four and more point functions."

Theta::usage = "
Theta is an Option of CreateTopologies. It determines wether the \n
starttopology `theta' should be included or not."

Eight::usage = "
Eight is an Option of CreateTopologies. It determines wether the \n
starttopology `eight' should be included or not."

Bicycle::usage = "
Bicycle is an Option of CreateTopologies. Bicycle -> True \n
includes the starttopology formed like a dump-bell. "

Begin["`Private`"]

                                    (**   start-Topologies **)

   tt = Topology[1][   Propagator[ex][e[1],v3[1]],
                       Propagator[ex][e[2],v3[1]],
                       Propagator[ex][e[3],v3[1]]    ];

   o1 = Topology[2][   Propagator[l1][ v3[1] , v3[1] ],
                       Propagator[ex][ e[1] , v3[1] ]    ];

   d1 = Topology[12][  Propagator[l1][ v3[-2] , v3[-1] ],
                       Propagator[l2][ v3[-2] , v3[-1] ],
                       Propagator[l3][ v3[-2] , v3[-1] ]    ];

   d2 = Topology[8][   Propagator[l1][ v4[-1] , v4[-1] ],
                       Propagator[l2][ v4[-1] , v4[-1] ]   ];
   
   d3 = Topology[8][   Propagator[l1][ v3[-1] , v3[-1] ],
		       Propagator[l2][ v3[-2] , v3[-2] ],
		       Propagator[l3][ v3[-2] , v3[-1] ]   ];

               (** recursive creation of topologies             **)
               (** starttopologies for 2-loop depend on options **)

  ConstructTopologies[0,3]  = TopologyList[tt];
  ConstructTopologies[1,1]  = TopologyList[o1];

  ConstructTopologies[loops_, ext_Integer] :=
    TopologyList[ Map[ AddOne[#1,ext]& , 
		  ConstructTopologies[loops,ext-1 ] ] ] ;

                           (** main function, checking options **)

  Options[ CreateTopologies ] =
	  {   Tadpoles             ->True ,
         SelfEnergies         ->True ,
	      Triangles            ->True ,
         Boxes                ->True ,
	      WFCorrections        ->True ,
	      Theta                ->True ,
	      Eight                ->True ,
	      Bicycle              ->False  };

  CreateTopologies[l_, n_Integer, options___ ] := 
  CreateTopologies[l, n, options ] = 
    Module[{defaults,topos},
	   defaults = Options[ CreateTopologies ];
           ConstructTopologies[2,0] = TopologyList[];
	   If[ Theta/.{options}/.defaults , 
	       ConstructTopologies[2,0]=
		   Append[ ConstructTopologies[2,0] , d1 ] ];
	   If[ Eight/.{options}/.defaults , 
	       ConstructTopologies[2,0]=
		   Append[ ConstructTopologies[2,0] , d2 ] ];
	   If[ Bicycle/.{options}/.defaults , 
	       ConstructTopologies[2,0]=
		   Append[ ConstructTopologies[2,0] , d3 ] ];
	   topos = ConstructTopologies[l,n];
	   If[ Not[ Tadpoles/.{options}/.defaults ],
	       topos = NoTadpoles[ topos ]          ];
	   If[ Not[ WFCorrections/.{options}/.defaults ],
	       topos = NoWFCorrections[ topos ]          ];
	   If[ Not[ SelfEnergies/.{options}/.defaults ],
	       topos = NoSelfEnergies[ topos ]          ];
	   If[ Not[ Triangles/.{options}/.defaults ],
	       topos = NoTriangles[ topos ]          ];
	   If[ Not[ Boxes/.{options}/.defaults ],
               Do[ topos = NoBoxes[ topos, m ] , {m,4,n} ]     ];
	   Return[topos]
	  ];

OnLoopTest[ tt:Topology[_][___],i_Integer ] := 
 Module[{lprops},
    lprops = AtLoopPropagators[ tt ];
    Length[  Select[ lprops , !(FreeQ[#,ex]&&FreeQ[#,in])& ]  ] === i
 ] 

ExternalSelfEnergy[ tt:Topology[_][___] ] := 
 Module[{lprops},
    lprops = AtLoopPropagators[ tt ];
    Length[  Select[ lprops , !(FreeQ[#,ex]&&FreeQ[#,in])& ]  ] === 2 &&
    Length[  Select[ lprops , !(FreeQ[#,ex]             )& ]  ]  >  0 
 ] 

ExternalTadpole[ tt:Topology[_][___] ] :=
 Module[{lprops,inprop},
    lprops = AtLoopPropagators[ tt ];
    inprop =  Identity @@ Select[ lprops , !(FreeQ[#,in])& ];
    If[ inprop==={},Return[True] ] ;    (* only non-l propagator is external *)
    !FreeQ[ Union[ Select[ tt, !FreeQ[#,inprop[[1]]]& ],
                   Select[ tt, !FreeQ[#,inprop[[2]]]& ]  ],
            ex] 
 ]

AtLoopPropagators[ tt:Topology[_][___] ] :=
 Module[{lvertices},
    lvertices = Union[
                     Join @@ 
                       (Select[  tt , ( FreeQ[#,in] && FreeQ[#,ex] )&  ] /.
			              Propagator[_] -> List)
                     ]  ;
    Union @@ (Function[ z,Select[ tt , !FreeQ[#,z]& ] ] /@ lvertices)
       ]
    

NoTadpoles[ tt:TopologyList[_] ] := 
	    Select[ tt , Not[OnLoopTest[#,1 ]]& ];

NoSelfEnergies[ tt:TopologyList[_]  ] := 
	        Select[ tt , Not[OnLoopTest[#,2 ]]& ];

NoTriangles[ tt:TopologyList[_]  ] := 
	    Select[ tt , Not[OnLoopTest[#,3 ]]& ];

NoBoxes[ tt:TopologyList[_] , i_Integer  ] := 
	    Select[ tt , Not[OnLoopTest[#,i ]]& ];

NoWFCorrections[ tt:TopologyList[_]  ] := 
            Union[ NoTadpoles[NoSelfEnergies[ tt ]],
		             Select[ Select[ tt,OnLoopTest[#,2]& ],
			                          !ExternalSelfEnergy[#]&      ],
		             Select[ Select[ tt,OnLoopTest[#,1]& ],
			                          !ExternalTadpole[#]&         ]
		           ];

(* the functions : *)
                                 (** construct the vertices **)

Vs[3][t_]:= Union[ Flatten[ List@@(Cases[ #1 , v3[n_] -> n ]& /@ t) ]];

Vs[4][t_]:= Union[ Flatten[ List@@(Cases[ #1 , v4[n_] -> n ]& /@ t) ]];

Vsn[type_Integer?Positive][t_] :=  Select[ Vs[type][t] , (#1<0)& ];

                                    (** for permutations **)

SwapV[ x_ , old_List , new_List ] :=           
        ( x /. Thread[ v3 /@ old -> v3 /@ new ] 
            )/.Thread[ v4 /@ old -> v4 /@ new ] ;

                                   (** adding to one propagator **)

PropPlus[ Propagator[h_][f_,t_],n_Integer] :=      
 If[ !(h===ex),                         
   Topology[h][ Propagator[h][f,v3[n]] , Propagator[h][v3[n],t] , 
		Propagator[ex][e[n],v3[n]] ],
   Topology[h][ Propagator[h][f,v3[n]] , Propagator[in][v3[n],t] , 
		Propagator[ex][e[n],v3[n]] ]
   ];

              (** conserve and destroy information about addition **)

ConstructAdditionalInfor = 
	  Topology[s_][ p1___,Topology[sp_][arg__],p2___ ] :> 
          Topology[ s sp ][p1,arg,p2];

DeleteAdditionalInfor = 
	  Topology[ s_Integer:1 v_Symbol:v3 ][p__] :> Topology[s][p] ;

             (** adding propagator #n to propagator and vertex #m **) 

AddPropagator[ Topology[s_][ x:Propagator[___][__].. ],
	       n_Integer,m_Integer                      ] :=
   (Topology[s][x] /. 
     Topology[s][x][[m]] -> PropPlus[Topology[s][x][[m]],n]
    )/. ConstructAdditionalInfor;
   
AddV3[ Topology[s_][ x:Propagator[___][__].. ],n_Integer,m_Integer ] :=
       Module[ {return,ch},
             return=Topology[s v3][x , 
                        Propagator[ex][ e[n],v4[n] ]] /.v3[m]->v4[n];
             If[ m<0 , return = (Topology[s vc]) @@ return ];
             return=return/.ConstructAdditionalInfor;
             ch=Vsn[3][ Topology[x] ];
             If[ Length[ch]>1,
                return=SwapV[ return,Vsn[3][return],
                               Table[-i,{i,Length[Vsn[3][return]]}] ],
                return
               ]
            ];

                (** adding propagator #n to all other propagators **)

AddPropagator[ Topology[s_][ x:Propagator[___][__].. ] , n_Integer ] :=
       Apply[ TopologyList, 
              Array[ AddPropagator[Topology[s][ x ],n,#1]&,Length[{x}] 
		   ]
            ];

                      (** adding propagator #n to all 3-vertices **)

AddV3[ Topology[s_][ x:Propagator[___][__].. ] , n_Integer ] :=
       Apply[ TopologyList,
              Map[ AddV3[ Topology[s][ x ],n,#1]& , 
		   Vs[3][ Topology[x] ] ]
            ];

                                   (** putting it all together **)

AddOne[ t:Topology[s_][__],n_Integer ] := 
  Module[{a,b},
	a=TopologiesCompare[ AddPropagator[ t , n ] ]   ;
        b=TopologiesCompare[ AddV3[ t , n ] ]   ; 
	TopologyList[ a  , b  ]
       ] ;

          (** TopologiesCompare routine (using Utilities`Compare) **)

TopologiesCompare[ TopologyList[],mod___ ] := TopologyList[];

TopologiesCompare[ tt:TopologyList[__] ] :=  
    Module[{notequal,posequal},
	  check = Function[ z ,(Head[ Head[z][[1]] ] === 1 )||
                               (Head[ Head[z][[1]] ] === Symbol)
                               ||(MemberQ[ Head[z][[1]] , in ] )
                               ||(MemberQ[ Head[z][[1]] , ex ] )
                               ||(MemberQ[ Head[z][[1]] , v3 ] )];
          notequal = Select[ tt , check ];
          posequal = Select[ tt , !MemberQ[notequal,#]& ];
	  posequal = Compare[ posequal ] //.DeleteAdditionalInfor;
          notequal = notequal //.DeleteAdditionalInfor;
          Append[notequal,posequal]
         ];  

End[]

EndPackage[]
