(* *********************************************************** *)
(*                                                             *)
(**                    Paint.m                                **)
(*                                                             *)
(*   graphic routine for FeynArts                              *)
(*   by Sepp Kueblbeck and Hagen Eck (last change: 08/91)      *)
(*                                                             *)
(* *********************************************************** *)

BeginPackage["Paint`","FeynArts`","InsertFields`"]

Needs["Utilities`DrawLine`"]
Needs["Utilities`GraphPoints`"]

Paint::usage = "
Paint[ t, v, h, options ] returns a Graphic object of graph t. \n
v and h are vertical and horizontal offset respectively."

FeynEdit::usage = "
FeynEdit[ topology ] is a primitive interactive topology-editor. \n
It should work for inserted as well as for bare topologies. \n
For bare topologies the usage is : \n
FeynEdit[ topology, NrOfInc, NrOfOut ]. FeynEdit is invoked auto- \n
matically, when Paint is called with the Option AutoEdit->True."

PaintScaling::usage = " 
PaintScaling gives the number of gridpoints when drawing a feynman \n
graph."

GrayBackground::usage = "
GrayBackground is an option of Paint."

ShowGrid::usage = "
ShowGrid is an option of Paint that shows the grid (with dimensions \n
PaintScaling * PaintScaling) on which the vertices are located."

ShowPointNames::usage = "
ShowPointNames is an option of Paint that displays the names of the \n
vertices in a feynmangraph."

GraphPerRow::usage = "
GraphsPerRow is an option of Paint (default=2)."

RowsPerSheet::usage = "
RowsPerSheet is an option of Paint (default=3)."

AutoEdit::usage = "
AutoEdit is an option of Paint that determines, wether FeynEdit \n
should be called automatically when a undefined topology occurs." 

ScreenOutput::usage = "
ScreenOutput is an option of Paint that determines, wether screen \n
output is desired or not. If ScreenOutput is set to False, then Paint \n
will return a Graphics object."

PropagatorThickness::usage = "
PropagatorThickness is an option of Paint that determines the thick- \n
ness of the propagators."

VertexSize::usage = "
VertexSize is an option of Paint that determines the size of the \n
internal fieldpoints of a feynmangraph."

FullNumbering::usage = "
FullNumbering is an option of Paint that determines whether the \n
total number of graphs drawn so far is appended to the name of the \n
feynmangraphs."

FeynArtsGraphics::usage = "
FeynArtsGraphics is an graphics object returned by the FeynArts Paint 
routine."

Options[Paint] = {
		     GraphsPerRow        -> 3,
                     RowsPerSheet        -> 3,
                     ScreenOutput        -> True,
		     PSFileOutput	 -> True,
                     ScreenMessages      -> True,
                     AutoEdit            -> False,
		     FullNumbering       -> False,
                     GrayBackground      -> False,
                     ShowGrid            -> False,
                     ShowPointNames      -> False,
                     PropagatorThickness -> Automatic,
		     VertexSize          -> Automatic
                    }

Begin["`Private`"]

PaintScaling = 20;

FeynArtsGraphics/: Show[ FeynArtsGraphics[ fag___ ] ] := (Show[fag];
                         FeynArtsGraphics[fag])

Unprotect[Show];
Show[ { h_[ sth__ ], m___ } ] := Show/@ { h[sth], m } /; h===FeynArtsGraphics;
Protect[Show];

Format[ FeynArtsGraphics[ ___ ] ] = "-FeynArtsGraphics-"
                  
                      (** rules to set outputfont **)

ScreenFontRule = {
  FontForm[ Greek[a_] , OutFont ] :> FontForm[ a , $ScreenSymbolFont ],
  FontForm[ Greek[a_] , SmallOutFont ] :> FontForm[ a,$SmallScreenSymbolFont ],
  FontForm[ a_ , OutFont ] :> FontForm[ a , $ScreenTextFont ],
  FontForm[ a_ , SmallOutFont ] :> FontForm[ a,$SmallScreenTextFont ],
  FontForm[ a_ , None           ] :> FontForm[ NoGreek[a] , $ScreenTextFont ] }

PrinterFontRule = {
  FontForm[ Greek[a_] , OutFont ] :> FontForm[ a , $PrinterSymbolFont ],
  FontForm[ Greek[a_] , SmallOutFont ] :> FontForm[ a,$SmallPrinterSymbolFont ],
  FontForm[ a_ , OutFont ] :> FontForm[ a , $PrinterTextFont ],
  FontForm[ a_ , SmallOutFont ] :> FontForm[ a,$SmallPrinterTextFont ],
  FontForm[ a_ , None           ] :> FontForm[ NoGreek[a] , $PrinterTextFont ] }

                      (** main draw routine (1) : list of graphs **)

Paint[ TopologyList[ descr__ ][ insertedtopologies__ ], 
       opt___Rule ]:=
Module[ {graphsperrow, rowspersheet, onesheet,
         totalheight, totalwidth, centerparam, sheetposition, 
         thicknessoption, vertexsizeoption, graphheader,headerlength,
	 xoffset, yoffset, symb, returngraphics={},
         currenttopology, currentgraph, graphnr=0,
         graphdistance = 1.2, eventlist, modelfile },
       (* reading model file if not initialized yet : *)
       (If[ Not[   MemberQ[ SymbolToModel /@ InitializedModels,# ]
               || #===Topology] ,
            Off[ Syntax::newl ]; 
 	    Get @@ 
	     Select[ $ModelFiles ,
                Function[ z,StringMatchQ[ z,StringJoin["*.", ToString[#]] ]]];
            On[ Syntax::newl ];
           ])& /@ (Model/.{descr});
       symb = If[ (ProcessName/.{descr}) === ProcessName ,
              Untitled, ProcessName/.{descr} ];
       (* checking the options : *)
       graphsperrow = GraphsPerRow/.{opt}/.Options[Paint] ;
       rowspersheet = RowsPerSheet/.{opt}/.Options[Paint] ;
       totalwidth = graphsperrow*graphdistance*PaintScaling;
       totalheight = rowspersheet*graphdistance*PaintScaling;
       centerparam = Max[totalheight,totalwidth];
       If[ !(ScreenMessages/.{opt}/.Options[Paint]),
           $Output = {FeynArtsNullDevice}
         ];
       If[ PSFileOutput/.{opt}/.Options[Paint],
           Off[DeleteFile::nffil];
           If[ DeleteFile[
		StringJoin[ToString[symb],".gra"]] === $Failed,
               Print["write to file \"",ToString[symb],".gra\""],
               Print["overwrite file \"",ToString[symb],".gra\""]];
           On[DeleteFile::nffil];
           OpenAppend[StringJoin[ToString[symb],".gra"]]
         ];
       If[ (PropagatorThickness/.{opt}/.Options[Paint])===Automatic,
           thicknessoption = 
	     Rule[PropagatorThickness,
                  25./(graphsperrow*rowspersheet)] ,
           thicknessoption = 
	     Rule[PropagatorThickness,
                  PropagatorThickness/.{opt}/.Options[Paint]] ]; 
       If[ (VertexSize/.{opt}/.Options[Paint])===Automatic,
            vertexsizeoption = 
	      Rule[ VertexSize, 9./Sqrt[graphsperrow*rowspersheet]],
            vertexsizeoption = 
	      Rule[ VertexSize, Vertexsize/.{opt}/.Options[Paint]] ];
       (* loop *)
       onesheet = {};
       Do[
         currenttopology = {insertedtopologies}[[ct]];
         If[ Length[ Last[currenttopology] ] > 0 ,
         Do[
          graphnr++;
          currentgraph = 
          Append[ Drop[ currenttopology, -1 ],
                  Insertions[ Last[currenttopology][[cg]] ] ];
	  If[ graphnr === 1,
	      graphheader = MakeGraphHeader[ Drop[ currentgraph,-1]/.(
	       				     List@@ Last[currentgraph][[1]])];
	      headerlength=Length[graphheader];
	      graphheader = (FontForm[#,OutFont]& /@ graphheader);
	      graphheader = Array[ Pair[ graphheader[[#]],# ]&,
				   Length[graphheader] ] //.
		( {f___,Pair[FontForm[Sub[a_,b_],OutFont],i_Integer],g___} :> 
		  {f,Pair[FontForm[a,OutFont],i], 
		   Pair[FontForm[b,SmallOutFont],i],g} );
              graphheader = graphheader /.
                { Pair[ FontForm[a_,OutFont] , i_Integer ] :>
			Text[ FontForm[a,OutFont],
			      { (totalwidth-0.2*PaintScaling)/2.
				+PaintScaling*(i-(headerlength)/2)/5,
				 totalheight - 1.5 }  ],
                  Pair[ FontForm[a_,SmallOutFont] , i_Integer ] :>
			Text[ FontForm[a,SmallOutFont],
			      { (totalwidth-0.2*PaintScaling)/2.
				+PaintScaling*0.05
			        +PaintScaling*(i-(headerlength)/2)/5,
			        (- PaintScaling*0.03
                                +totalheight - 1.5) }  ]
			      }
	     ];
	  sheetposition = Mod[ graphnr, graphsperrow*rowspersheet ];
          xoffset = Mod[ sheetposition-1, graphsperrow ]*
                         graphdistance*PaintScaling;
	  yoffset = If[sheetposition===0, 0,
                     (rowspersheet - 1 -
                     Quotient[ sheetposition-1, graphsperrow ])*
                         graphdistance*PaintScaling];
          If[ ScreenMessages /. {opt} /. Options[Paint] ,
              Print[  "topology: ",ct,
		    "  insertion: ",cg,
		    "  nr: ",graphnr]   ];
          AppendTo[ onesheet,
            List@@ PaintSingle[ currentgraph,
                          yoffset, xoffset,
			  If[ (Model/.{descr})==={Topology},
			      GraphName[ct,0,0,0],
                              If[ FullNumbering/.{opt}/.Options[Paint],
                                  GraphName[ct,cg,graphnr],
     			          GraphName[ct,cg]
                                ]
			     ],
                          opt, ScreenOutput->False, 
                          thicknessoption , vertexsizeoption ]  ];
          If[ Last[ onesheet ] === $Aborted,
              onesheet = onesheet/.{$Aborted:>
                                   {Text["? ? ?",
                                         {xoffset+10.,yoffset+10.}]}}
            ];
          If[ sheetposition === 0 ||
              ( ct===Length[{insertedtopologies}] &&
                cg===Length[Last[currenttopology]] &&
		onesheet =!= {} ) ,
	      onesheet = Join[ onesheet, graphheader ]; 
              onesheet =  
              Graphics[ onesheet, 
			AspectRatio -> 1,
                        PlotRange   -> {{-1.,centerparam},
				        {-1.,centerparam}} ];
	      If[ ScreenOutput/.{opt}/.Options[Paint],
                  Show[ onesheet//.ScreenFontRule ]
		 ];
              AppendTo[ returngraphics, onesheet ];
	      If[  PSFileOutput//.{opt}/.Options[Paint],
                   Display[ StringJoin[ToString[symb],".gra"],
                             onesheet//.PrinterFontRule ]  ;
		   Put[ Global`showpage, 
			StringJoin[ToString[symb],".gra"] ]  
		];
              onesheet = {}
	    ];
          If[ ( ct===Length[{insertedtopologies}] &&
                cg===Length[Last[currenttopology]] ) , 
              If[PSFileOutput/.{opt}/.Options[Paint],
	         Close[StringJoin[ToString[symb],".gra"]]
	         ]   
             ],
          {cg,Length[Last[currenttopology]]}
           ],
          If[ ct===Length[{insertedtopologies}],
              onesheet =  
              Graphics[ onesheet, 
			AspectRatio -> 1,
                        PlotRange -> {{-1.,Max[totalwidth,totalheight]},
				      {-1.,Max[totalwidth,totalheight]}} ];
	      If[ ScreenOutput/.{opt}/.Options[Paint],
                  Show[ onesheet//.ScreenFontRule ]
		];
              AppendTo[ returngraphics, onesheet//.ScreenFontRule ];
	      If[ PSFileOutput/.{opt}/.Options[Paint],
                  Display[StringJoin[ToString[symb],".gra"],
			  onesheet//.PrinterFontRule]; 
                  Close[StringJoin[ToString[symb],".gra"]]
	        ]                    
            ]
          ], 
         {ct,Length[{insertedtopologies}]}
        ];
       $Output = {"stdout"};
       Return[FeynArtsGraphics/@(returngraphics//.ScreenFontRule)]
      ]
                    (** special case : drawing topologies **)

Paint[ Topology[s_][ props:Propagator[_][__].. ],
       ninc_Integer, nout_Integer, options___Rule ] :=
    Paint[ TopologyList[ Topology[s][ props] ], ninc, nout, options,
           GraphsPerRow->2,
	   RowsPerSheet->2  ]
	   
Paint[ TopologyList[ baretopologies__],ninc_Integer,nout_Integer,
                     options___Rule ] :=
       Paint[ InsertFields[ TopologyList[baretopologies],
                            ninc,nout],options ]

         	  (** main draw routine (2) : single topology **)

Paint[ Topology[ props__, 
                 Insertions[ vers:Graph[_][__], more___ ] ],
        opt___Rule ] :=
Module[ {graphsperrow, rowspersheet, 
         thicknessoption, vertexsizeoption, onesheet,
         totalheight, totalwidth, sheetposition, 
	 xoffset, yoffset,returngraphics={},
         graphdistance = 1.2, insertionlist },
       graphsperrow = GraphsPerRow/.{opt}/.Options[Paint] ;
       rowspersheet = RowsPerSheet/.{opt}/.Options[Paint] ;
       totalwidth = graphsperrow*graphdistance*PaintScaling;
       totalheight = rowspersheet*graphdistance*PaintScaling;
       If[ (PropagatorThickness/.{opt}/.Options[Paint])===Automatic,
           thicknessoption = 
	      Rule[PropagatorThickness,
                   25./(graphsperrow*rowspersheet)] ,
           thicknessoption = 
	      Rule[PropagatorThickness,
                   PropagatorThickness/.{opt}/.Options[Paint]] ]; 
       If[ (VertexSize/.{opt}/.Options[Paint])===Automatic,
            vertexsizeoption = 
	      Rule[ VertexSize,9./Sqrt[graphsperrow*rowspersheet]],
            vertexsizeoption = 
	      Rule[ VertexSize,Vertexsize/.{opt}/.Options[Paint]] ];
       insertionlist = Insertions /@ {vers, more};
       If[ PSFileOutput/.{opt}/.Options[Paint],
           Off[DeleteFile::nffil];
           If[ DeleteFile["topol.gra"] === $Failed,
               Print["write to file \"","topol.gra\""],
               Print["overwrite file \"","topol.gra\""]  ];
           On[DeleteFile::nffil];
           OpenAppend["topol.gra"]
         ];
       onesheet={};	
       Do[
	  sheetposition = Mod[ n , graphsperrow*rowspersheet ];
          xoffset = Mod[ sheetposition-1, graphsperrow ]*
                         graphdistance*PaintScaling;
	  yoffset = If[sheetposition===0, 0,
                     (rowspersheet - 1 -
                     Quotient[ sheetposition-1, graphsperrow ])*
                         graphdistance*PaintScaling];
          AppendTo[ onesheet,
          List@@ PaintSingle[ Topology[ props, insertionlist[[n]] ],
                           yoffset,xoffset,
			   GraphName[n] ,
                           thicknessoption, vertexsizeoption, opt,
                           ScreenOutput->False                    ]
          ];
          If[ Last[ onesheet ] === $Aborted ,
              onesheet = onesheet/.{ $Aborted:>
                                    {Text["? ? ?",
                                          {xoffset+10.,yoffset+10.}]}}
            ];
          If[ sheetposition === 0 ||
              n === Length[insertionlist] , 
              onesheet =  
              Graphics[ onesheet, 
			AspectRatio -> 1,
                        PlotRange -> {{-1.,Max[totalwidth,totalheight]},
	    			      {-1.,Max[totalwidth,totalheight]}} ];
	      If[ ScreenOutput /.{opt}/.Options[Paint] ,
                  Show[ onesheet//.ScreenFontRule ]
		 ];
              AppendTo[ returngraphics,onesheet ];
	      If[ PSFileOutput //.{opt}/.Options[Paint],
                  Display["topol.gra",onesheet//.PrinterFontRule] 
                ];
              onesheet = {}
	    ];
          If[ n===Length[insertionlist], 
	      If[PSFileOutput//.{opt}/.Options[Paint],Close["topol.gra"] ]
	    ],
          {n,Length[insertionlist]}
	 ];
        Return[FeynArtsGraphics/@(returngraphics//.ScreenFontRule)]
      ]
            
   (** draw one single graph (construct the graphics primitives) **)

PaintSingle[ Topology[ props__,Insertions[ vers:Graph[_][__] ] ],
       yoff_, xoff_, GraphName[ t___ ], opt___Rule ] :=
  Module[{graphprim,labelprim},
        labelprim = Which[
	    Length[{t}]===1 ,{Text[ FontForm[StringJoin["Ins.",ToString[{t}[[1]]]],
                                        OutFont],
	    			     {.2+xoff,.2+yoff},{-1,-1}] },
	    Length[{t}]===4 , {Text[FontForm[StringJoin["Top.",ToString[{t}[[1]]]],
                                        OutFont],
	    			     {.2+xoff,.2+yoff},{-1,-1}] },
	    Length[{t}]===2 , {Text[FontForm[StringJoin["Top.",ToString[{t}[[1]]],
			                      " Ins.",ToString[{t}[[2]]]],
                                        OutFont],
				     {.2+xoff,.2+yoff},{-1,-1}]      },
	    Length[{t}]===3 , { Text[FontForm[StringJoin["Top.",ToString[{t}[[1]]],
					       " Ins.",ToString[{t}[[2]]],
					       "-",ToString[{t}[[3]]]], 
                                        OutFont],
				     {.2+xoff,.2+yoff},{-1,-1}]      }
	    ];	
        graphprim = PaintSingle[ Topology[props,Insertions[vers]],
                           yoff, xoff, opt, ScreenOutput->False   ];
	If[ graphprim === $Aborted,
            Return[ $Aborted ], 
            graphprim = Graphics[ Join[ List@@graphprim,labelprim ] ]
          ];
        If[ !(ScreenOutput/.{opt}/.Options[Paint]),
            Return[ graphprim ],
            AppendTo[ graphprim,#]& /@ { 
                      AspectRatio->1,
                      PlotRange->{{-.5,.5+PaintScaling+xoff},
                                  {-.5,.5+PaintScaling+yoff}} };
	    Show[ graphprim ];
	    Return[graphprim]
          ]
        ]
            

PaintSingle[ Topology[props__,Insertions[ vers:Graph[_][__] ] ], 
       voff_, hoff_,  opt___Rule ] :=
  Module[ { localoptions,holdoptions,
           scalefactor=PaintScaling, 
           propagatorthickness, vertexsize,
	   baretop, thelines, thefields, graphinfo,
	   feynartsgraphic } ,
	If[ {opt} == {} ,
	    localoptions = Options[Paint] ,
	    holdoptions = Options[Paint];
	    localoptions = SetOptions[ Paint, ## ]& @@
		         Select[ Select[{opt},FreeQ[#,Process]&],FreeQ[#,ProcessName]& ];
	    Options[Paint] = holdoptions
	  ];
        If[ (PropagatorThickness/.localoptions) === Automatic,
            propagatorthickness = 4,
            propagatorthickness = PropagatorThickness/.localoptions
          ];
        If[ (VertexSize/.localoptions) === Automatic,
            vertexsize = 4,
            vertexsize = VertexSize/.localoptions
          ];
        feynartsgraphic= {};
	If[ GrayBackground/.localoptions ,
	    feynartsgraphic = 
	    Append[ feynartsgraphic, FeynRaster[scalefactor] ]
	  ];
	If[ ShowGrid/.localoptions,
	    feynartsgraphic = 
	    Join[ feynartsgraphic, Prepend[FeynGrid[scalefactor],
					  PointSize[.01] ] ]
	  ];
	feynartsgraphic = feynartsgraphic/.{a_?NumberQ,b_?NumberQ}:>
					    N[ {a+hoff,b+voff} ];
(* seperate topological and field information : *)
        baretop = Sort[ Sort/@ (Take[#,2]& /@ Topology[props])/.{
			inc->zzx,out->zzy }]/.{zzx->inc,zzy->out};
	thefields = #[[3]]& /@ Sort[ Topology[ props ]/.{
			inc->zzx,out->zzy }]/.{zzx->inc,zzy->out};
(* get point locations or call FeynEdit or abort *)
	If[ 
           Head[graphinfo=
                GraphPoints[baretop,
                            NumberOfInc[baretop],
                            NumberOfOut[baretop] ]]===List,
	        graphinfo = graphinfo/.{
		     {a_?NumberQ,b_?NumberQ}:>N[{a+hoff,b+voff}] },
           If[ AutoEdit/.localoptions,
               FeynEdit[ baretop,
                         NumberOfInc[baretop],
                         NumberOfOut[baretop]  ];
	       graphinfo = GraphPoints[ baretop,
				        NumberOfInc[baretop],
					NumberOfOut[baretop] ];
	       graphinfo = graphinfo/.{
		     {a_?NumberQ,b_?NumberQ}:>N[{a+hoff,b+voff}] },
               Print["!! no point specifications for ",
		      "this topology !! "];
               Print["   (use FeynEdit first)"];
	       Return[$Aborted] 
             ]
          ];
	feynartsgraphic = Join[ feynartsgraphic , 
            VertexPlot[ graphinfo,vertexsize,
                        ShowPointNames/.localoptions ] ];
	feynartsgraphic = Join[ feynartsgraphic ,
				{PointSize[.00001],Point[{0.,0.}]} ];
	thelines = Apply[Append,#]& /@
		   Transpose[ {List@@baretop,graphinfo[[1]]} ];
	thelines = Apply[Append,#]& /@
		   Transpose[ {thelines,List@@thefields} ];
        thelines = thelines  /.List@@vers /. graphinfo[[2]]//.(
	    li:List[ a___, pr:Propagator[type_][v___,DummyField[1]], b___] :>
            List[ a,Propagator[type][v,Position[li,pr][[1,1]]],b] );
        thelines = thelines /.{ Propagator[_][ins__]:>
                    DrawLine[ins,scalefactor,propagatorthickness]};
        feynartsgraphic = Join[ feynartsgraphic , thelines ];
        If[ ScreenOutput/.localoptions,
	    feynartsgraphic = Graphics[ feynartsgraphic,
                 AspectRatio->1,
                 PlotRange->{{-.5+hoff,.5+PaintScaling+hoff},
                             {-.5+voff,.5+PaintScaling+voff}}];
	    Show[ feynartsgraphic//.ScreenFontRule ]
	   ];
        Return[ Graphics[ feynartsgraphic ] ]
       ]
		  (* end of the Paint routine *)

MakeGraphHeader[ Topology[ inserted__ ] ] := 
  Module[{incoming,outgoing},
  	  incoming = #[[3]]& /@ Select[{inserted},
	  				MatchQ[#, Propagator[inc][__] ]& ];
  	  outgoing = #[[3]]& /@ Select[{inserted},
	  				MatchQ[#, Propagator[out][__] ]& ];
	  If[ Head[ incoming[[1]] ] === InsertFields`Private`TopDummy,
	      Return[{StringJoin["Topol ",ToString[Length[incoming]],
	                        " -> ",ToString[Length[outgoing]]]}]
	     ];
	  incoming = {#," + "}& /@ (LineSpec[#][[3]]& /@ incoming);
	  outgoing = {#," + "}& /@ (LineSpec[#][[3]]& /@ outgoing);
	  incoming = Drop[Flatten[incoming],-1];
	  outgoing = Drop[Flatten[outgoing],-1];
	  Return[ Flatten[{incoming," ","-->"," ",outgoing}]]
	  ]				
					
					
NumberOfInc[ top_ ] := Length[ Cases[ top, Propagator[inc][_,_] ] ]

NumberOfOut[ top_ ] := Length[ Cases[ top, Propagator[out][_,_] ] ]


                              (** make a list of bigger points **)

VertexPlot[{centers_List,vertices_List}, size_, shownames_ ] :=
  Module[{primitive,vplot},
        primitive = Select[ vertices, !MatchQ[ #, Rule[ e[_],_ ] ]& ];
        vplot = primitive/.Rule[ point_, coord_ ]:>Point[N[coord]];
(* changed PointSize from 0.003 to 0.005 *)
	vplot = Prepend[ vplot, PointSize[0.005*size] ];
        If[ shownames,
            vplot = Append[ vplot,
                            primitive/.{ Rule[point_,{cox_,coy_}] :>
                             Text[ ToString[point],
                                   N[ {cox+.5,coy+.5} ],
                                   {-1,-1}               ]       } ]
         ];
        Return[ vplot ]
       ]

                                (** defining the grids **)


FeynGrid[n_] := Flatten[ Array[ Point[N[{##}]]& , {n+1,n+1},0 ] ]

EmptyFeynGrid[n_] := {First[FeynGrid[n]],Last[FeynGrid[n]]}

FeynRaster[n_] := Raster[{{0.8}}, {{-.5,-.5}, {N[n]+.5,N[n]+.5}}] 

                                (** FeynEdit routine **)

FeynEdit[ Topology[ props__ , Insertions[__] ] ]:=
    FeynEdit[ Topology@@ ( Take[#,2]& /@ {props} ) ] 

FeynEdit[ Topology[ props:Propagator[_][_,_].. ] ] :=
    FeynEdit[ Topology[ props ],
              NumberOfInc[ Topology[props] ],
              NumberOfOut[ Topology[props] ]  ]

FeynEdit[ Topology[_][ props:Propagator[_][_,_].. ] , nri_, nro_ ] :=
    FeynEdit[ Topology[ props ] /.IncOutSpecification[nri,nro], 
              nri, nro ]

IncOutSpecification[ nin_, nou_ ] :=
 Join[ Array[ RuleDelayed[ 
                    Propagator[ex][e[#],vert_] ,
                    Propagator[inc][e[#],vert]   ]& , nin ],
       Array[ RuleDelayed[
                    Propagator[ex][e[#],vert_] ,
                    Propagator[out][e[#],vert]   ]& , nou , nin+1 ]
     ]

FeynEdit[ Topology[ props:Propagator[_][_,_].. ], 
	  nrin_, nrout_ ] :=
Module[ {workingtop,edittop,command,graphfile},
       graphfile = ContextToFilename["GraphInfo`GraphInfo`"];
       edittop = Sort[ Sort/@ (Take[#,2]& /@ Topology[props])/.{
			inc->zzx,out->zzy }]/.{zzx->inc,zzy->out};
       workingtop = Topology@@ Join[AppendIndex[Sort/@{props}],
			    DummyFieldInsertions[Length[{props}]]];
       If[!(Head[ GraphPoints[edittop,nrin,nrout] ]===List),
          SetRandomPoints[edittop,nrin,nrout] ];
       Print["for help type `h'"];
       command="s";
       While[ command!="x",
	      Which[ command == "s",
                     PaintSingle[ workingtop , 0. , 0., 
                            ShowGrid->True, 
			    ShowPointNames->True,
                            PropagatorThickness->12,
                            VertexSize->8            ],
		     command == "f",
		     Print["write to file \"",graphfile,"\""];
		     DeleteFile[ graphfile ];
		     Save[graphfile,GraphPoints],
		     command == "h",
		     PrintFeynEditHelp[] ,
                     command == "r",
                     SetRandomPoints[edittop,nrin,nrout] ,
   		     command == "p",
                     PrintPoints[ edittop,nrin,nrout ] ,
                     command == "v",
                     VertexShift[ edittop,nrin,nrout ],
                     command == "c",
                     CenterChoice[ edittop,nrin,nrout ],
		     command == "u",
                     GraphShift[ edittop,nrin,nrout ] ,
                     command == "d",
                     DisplacementChoice[ edittop,nrin,nrout ]
                      ];
	      command = InputString["FeynEdit> "] ]
	  
      ]

PrintFeynEditHelp[] :=
 (
  Print["the following commands are available :"];
  Print["  c  (center)   choose coordinates of center of line"];
  Print["  d  (displace) choose curvature of line"];
  Print["  f  (file)     save the GraphPoints-functions"];
  Print["  h  (help)     this message"];
  Print["  p  (print)    print the topology (propagators+centers)"];
  Print["  r  (roll)     randomize internal points (roll the dice)"];
  Print["  s  (show)     display the current topology with grid"];
  Print["  u  (up)       shift the complete graph in y-direction"];
  Print["  v  (vertex)   shift a vertex"];
  Print["  x  (exit)     leave FeynEdit"]
 )


PrintPoints[ edittop_,nrin_,nrout_ ] :=
Module[{propinfo},
       propinfo = List@@edittop;
       propinfo = Transpose[{propinfo ,
                             GraphPoints[edittop,nrin,nrout][[1]] ,
                             Array[#&,Length[propinfo]]   }];
       PrintProp/@ propinfo;
       PrintCoord /@ GraphPoints[ edittop, nrin, nrout ][[2]]
      ]

PrintProp[ {Propagator[_][ from_,to_ ],center_,numb_} ] :=
         Print["    ",from,"  -->  ",to,"       ",
 	       "c[",numb,"] = ",
               If[ from==to && center==0, Automatic, center, center ]
              ]

PrintCoord[ Rule[ point_, coord_ ] ] :=
         Print["   ", point," = ", coord ]

AppendIndex[ pr_List ] := If[ Length[ pr[[1]] ] == 3,
			      pr,
			      Array[ Append[ pr[[#]] , fi[#] ]& ,
				     Length[ pr ] ]
			    ]

DummyFieldInsertions[ nr_Integer ] := {
	 Insertions[ Graph[1]@@Array[ (fi[#]->DummyField[1])& ,nr ]]}

SetRandomPoints[ tt_Topology, ni_, no_ ] := 
  Module[{randpoints,vert,holdvert,baretop,linemulti,se=2,te=2},
         randpoints = Array[ 
             e[#]->{0,
		    PaintScaling-Round[(2(#-1)+1)*(PaintScaling/(2 ni))]}& , 
		    ni ]; 
	 randpoints = Join[ randpoints ,
	              Array[ 
             e[#]->{PaintScaling,
                    PaintScaling-Round[(2(#-ni-1)+1)*(PaintScaling/(2 no))]}& ,
                     no , ni+1 ] ];
	 baretop = List@@tt/.Propagator[_]->List ;
	 vert = Union[
		 Select[ Flatten[ baretop ],
			Not[ Head[#] === e ]& ] ];
	 While[ 
	 !(Length[
	   Union[holdvert = Rule[ # , {Random[Integer,{3,PaintScaling-3}],
                               Random[Integer,{3,PaintScaling-3}]}]& /@
	         vert] ] === Length[vert] ) , Null ];
	 randpoints = Join[randpoints,holdvert ];
	 randpoints = { Table[0, {Length[tt]} ] , randpoints };
         Set[Literal[GraphPoints[tt,ni,no]],
	      randpoints ];
	 Do[ 
	    linemulti = Length[ Cases[ baretop, baretop[[i]] ] ];
	    If[ linemulti === 2 ,
	        DisplacementChoice[ tt,ni,no,i,se] ; se*=-1 ] ;
	    If[ linemulti === 3 , 
	        DisplacementChoice[ tt,ni,no,i,te] ; If[te===-2,te=2,te-=2]] ,
	    {i,Length[tt]}
	   ];
	]

    (** change position of a vertex (redefine GraphPoints-function) **)

VertexShift[ baretop_ , nrin_, nrout_ ] :=
  Module[{ vertexnr, xsh, ysh, props, cent, 
	   pointcoords, lab, lac, oac, oab, disp={}, dispsign},
        While[ !MemberQ[ Flatten[ baretop/.Propagator[_][a___]:>Topology[a] ],
                         vertexnr ],
         vertexnr = Input["    Vertex: "]  ];
        While[ !NumberQ[xsh],
         xsh = Input["      +x : "] ];
        While[ !NumberQ[ysh],
         ysh = Input["      +y : "] ]; 
	 props = Union[ #[[1]]& /@ Position[ baretop, vertexnr ] ];
         Do[
	    If[ (cent=GraphPoints[ baretop, nrin, nrout ][[ 1,props[[i]] ]]
		 ) =!= 0,
         	pointcoords = List@@ (baretop[[ props[[i]] ]] /.(
		 GraphPoints[ baretop,nrin,nrout ][[2]]));
		lac = Sqrt[(pointcoords[[1,1]] - cent[[1]])^2 +
		           (pointcoords[[1,2]] - cent[[2]])^2  ];
		lab = Sqrt[(pointcoords[[1,1]] - pointcoords[[2,1]])^2 +
		           (pointcoords[[1,2]] - pointcoords[[2,2]])^2 ];
	        oac = Orientation[ pointcoords[[1]],cent ];
		oab = Orientation[ pointcoords[[1]], pointcoords[[2]] ];
		dispsign = If[ oac > - N[Pi]/2 && oac < N[Pi]/2,
		               Sign[ oac - oab ],
			       Sign[ oac - oab ]*Sign[oab]*Sign[oac]
			      ];
		disp = Append[ disp, {props[[i]],
				      dispsign*lac Sin[ArcCos[lab/2/lac]]}]
	       ],
	    {i,Length[props]}
	   ];
         PointShift[ baretop, nrin, nrout, vertexnr, xsh, ysh ];
	 If[ disp =!= {} ,
	     DisplacementChoice[ baretop, nrin, nrout,
	                         #[[1]], #[[2]] ]& /@ disp
	    ]
	]
	
GraphShift[ baretop_, nrin_, nrout_ ] :=
  Module[{ysh},
        While[ !NumberQ[ysh],
         ysh = Input[" (all) +y : "] ];
         Set[ Literal[ GraphPoints[ baretop,nrin,nrout ] ],
              GraphPoints[ baretop,nrin,nrout ]/.{
              List[ xval_?NumberQ, yval_?NumberQ ] :>
              List[ xval, yval+ysh ] } ]
       ]

PointShift[ t_Topology, nrin_, nrout_, 
            vertex_ , xshift_ , yshift_:0 ] :=
 If[ Head[vertex]===Global`c,
     If[ GraphPoints[t,nrin,nrout][[1,vertex[[1]]]]===0,
         Print["-straight line- (use 'd')"],
         Set[ Literal[ GraphPoints[t,nrin,nrout] ],
           ReplacePart[ GraphPoints[t,nrin,nrout],
                        {GraphPoints[t,nrin,nrout][[1,vertex[[1]],1]]+
                         xshift,
                         GraphPoints[t,nrin,nrout][[1,vertex[[1]],2]]+
                         yshift},
                         {1,vertex[[1]]} ]
             ]
        ],
      Set[ Literal[ GraphPoints[t,nrin,nrout] ] ,
	   GraphPoints[t,nrin,nrout]/.{
	  		    Rule[ vertex,{xval_,yval_} ] :>
			    Rule[ vertex,N[{xval+xshift,yval+yshift}]]
			    }
	 ]
      ]

                                     (** choose curvature of line **)

DisplacementChoice[ baretop_, nrin_, nrout_ ] :=
  Module[{centernr, displ},
        While[ !MemberQ[Array[ Global`c[#]&,Length[baretop] ],centernr] ,
         centernr = Input["   Center: "] ];
        If[ baretop[[centernr[[1]],1]] === baretop[[centernr[[1]],2]] ,
            Print[" d cannot be used for closed propagators! "];
            Return[]  ];  
        While[ !NumberQ[displ],
         displ = Input[" displacement : "] ];
         If[ ! displ===0 ,
            displ = CalculateCenter[
                       Flatten[baretop[[centernr[[1]],1]]/.{
                        GraphPoints[baretop,nrin,nrout][[2]] }],
                       Flatten[baretop[[centernr[[1]],2]]/.{
                        GraphPoints[baretop,nrin,nrout][[2]] }],
                       displ ] 
           ];
         SetCenter[ baretop, nrin, nrout, centernr[[1]], displ ] 
        ]

DisplacementChoice[ baretop_, nrin_, nrout_, centernr_, howmuch_ ] :=
  Module[{displ},
         If[ howmuch===0 ,
	    displ = 0 ,
            displ = CalculateCenter[
                       Flatten[baretop[[centernr,1]]/.{
                        GraphPoints[baretop,nrin,nrout][[2]] }],
                       Flatten[baretop[[centernr,2]]/.{
                        GraphPoints[baretop,nrin,nrout][[2]] }],
                        howmuch ] 
           ];
         SetCenter[ baretop, nrin, nrout, centernr, displ ] 
        ]


CalculateCenter[{Xa_,Ya_},{Xb_,Yb_},length_ ] :=
Module[{Xm,Ym,angle},
       {Xm,Ym} = 1/2 {Xa+Xb, Ya+Yb} ;
       angle = Mod[Orientation[ {Xa,Ya}, {Xb,Yb} ] + N[Pi,10]/2,
                   2 N[Pi,10] ] ;
       { Xm + length Cos[angle] , Ym + length Sin[angle] }
      ] 

                     (** choose center of line by hand (tadpoles) **)

CenterChoice[ baretop_, nrin_, nrout_ ] :=
  Module[{centernr, xval, yval },
        While[ !MemberQ[Array[ Global`c[#]&,Length[baretop] ],centernr],
         centernr = Input["    Center: "] ];
        While[ !NumberQ[xval],
         xval = Input[" choose x : "] ];
        While[ !NumberQ[yval],
      	yval = Input[" choose y : "] ];
        SetCenter[ baretop, nrin, nrout, centernr[[1]], {xval,yval} ]
        ]

SetCenter[ t_Topology, nrin_, nrout_, cnr_, point_ ] :=
     Set[ Literal[ GraphPoints[ t, nrin, nrout ] ] ,
          ReplacePart[ GraphPoints[ t, nrin, nrout ],
                       point,
                       {1,cnr} ]
         ]

End[]

EndPackage[]

Null
