Making a list of rules from the list of elements

Question

Starting from the list:

{f[q1, q2], f[q3, q4], g[q1], g[q2, q3, q4], d[k1 - q1], d[k2 - q2 - q3 -q4]}    

I would like to get the result:

{f[q1, q2] -> g[q1], f[q1, q2] -> g[q2, q3, q4], f[q3, q4] -> g[q2, q3, q4], f[q3, q4] -> g[q2, q3, q4], g[q1] -> k1, g[q2, q3, q4] -> k2}    

by applying following two rules: first for all $q_i$ variables match $f[]$ to $g[]$ that contain the same $q_i$. If $f[]$ and $g[]$ contain more then one $q_i$ that is the same, then repeat the rule for each of such $q_i$, as in case of

f[q3, q4] -> g[q2, q3, q4]   

Second rule should mach $g[]$ to a given $k_i$ that are again related by the corresponding $q_j$ in $d[]$ element. In case of multiple $q_j$ relating $g[]$ to a given $k_i$ only one rule will suffice, as in case of

g[q2, q3, q4] -> k2   

How do I make a function that would produce such a list of rules for a given input list?

Note: Element $d[...]$ in the input list can be thought of as a delta function setting the external momenta.

Eventually I want to use the obtained rules to make a GraphPlot that corresponds to the Feynman diagram. Repeated rules then correspond to loops in a diagram.

Answer 1

ClearAll[f, g, q1, q2, q3, d, k1, k2]

your list:

flist = {f[q1, q2], f[q3, q4], g[q1], g[q2, q3, q4], d[k1 - q1], d[k2 - q2 - q3 - q4]}

First set of rules

Without repeated rules

Make a list of all possible combinations of f[_] and g[_] using Tuples, then Select the ones with IntersectingQ arguments, and change Head from List to Rule using Apply (@@, @@@)

Rule @@@ Select[
  Tuples[
   {
    Select[flist, Head[#] == f &],
    Select[flist, Head[#] == g &]
    }],
  IntersectingQ[List @@ #[[1]], List @@ #[[2]]] &
  ]

{f[q1, q2] -> g[q1], f[q1, q2] -> g[q2, q3, q4], f[q3, q4] -> g[q2, q3, q4]}

With repeated rules

Make a list of all possible combinations of f[_] and g[_] using Tuples, then repeat each combination the number of common arguments. Then change Head from List to Rule using Apply (@@, @@@)

Rule @@@ Flatten[
  Table[#, {Length[Intersection[List @@ #[[1]], List @@ #[[2]]]]}] & /@
  Tuples[{Select[flist, Head[#] == f &], Select[flist, Head[#] == g &]}], 1]

Second set of rules

Now depending how the second set of rules is defined:

If by the arguments in g[_]:

(this matches your example, but may no be what you meant, see also the next interpretation)

Select the g[_], take the fist argument and replace "q" for "k" , and change Head from List to Rule using Apply (@@@)

Rule @@@ (
  {#, ToExpression@
      StringReplace[ToString[First[List @@ #]], "q" -> "k"]} & /@ 
   Select[flist, Head[#] == g &]
  )

If by the arguments in d[_]:

Block[{dlist = Select[flist, Head[#] == d &], arglist, ks, gs},
 arglist = First /@ List @@@ dlist;
 ks = Select[#, StringMatchQ[ToString[#], "k" ~~ __] &] & /@ arglist;
 gs = If[ListQ[#], g @@ #, g@#] & /@ (List @@@ (ks - arglist));
 Rule @@@ Transpose[{gs, ks}]
 ]

{g[q1] -> k1, g[q2, q3, q4] -> k2}

Now you can just join the two lists of Rules