Commit c33112c3 authored by Thorsten Ohl's avatar Thorsten Ohl
Browse files

UFO: seagulls

parent a0a48250
...@@ -308,6 +308,8 @@ let lexicographic ?(cmp=Pervasives.compare) l1 l2 = ...@@ -308,6 +308,8 @@ let lexicographic ?(cmp=Pervasives.compare) l1 l2 =
lexicographic' (rest1, rest2) in lexicographic' (rest1, rest2) in
lexicographic' (l1, l2) lexicographic' (l1, l2)
(* If there was a polymorphic [Set], we could also say
[Set.elements (Set.union (Set.of_list l1) (Set.of_list l2))]. *)
let common l1 l2 = let common l1 l2 =
List.fold_left List.fold_left
(fun acc x1 -> (fun acc x1 ->
......
...@@ -136,7 +136,9 @@ val ariadne_unsort : 'a list * int list -> 'a list ...@@ -136,7 +136,9 @@ val ariadne_unsort : 'a list * int list -> 'a list
lexicographically. *) lexicographically. *)
val lexicographic : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int val lexicographic : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
(* [common l1 l2] returns the elements common to the lists [l1] and [l2]. *) (* [common l1 l2] returns the elements common to the lists [l1] and [l2].
The lists are not required to be ordered and the result will also
not be ordered. *)
val common : 'a list -> 'a list -> 'a list val common : 'a list -> 'a list -> 'a list
(*i (*i
......
...@@ -1147,6 +1147,10 @@ module Model = ...@@ -1147,6 +1147,10 @@ module Model =
let translate_color4_1_1 c = let translate_color4_1_1 c =
Q.make (translate_color_atom c) 1 Q.make (translate_color_atom c) 1
(* Take two lists of three indices each, find exactly one common index,
check that it is a summation index (i.\,e. not positive) and return
the remaining four indices in normal order (see [normalize_quartet])
together with the sign of the permutations. *)
let translate_color4_ff abc abc' = let translate_color4_ff abc abc' =
match ThoList.common abc abc' with match ThoList.common abc abc' with
| [] -> invalid_arg "translate_color4_ff: not summation index" | [] -> invalid_arg "translate_color4_ff: not summation index"
...@@ -1493,21 +1497,21 @@ i.e. ...@@ -1493,21 +1497,21 @@ i.e.
&& ThoList.homogeneous [ka1; nu2; la3] && ThoList.homogeneous [ka1; nu2; la3]
&& ThoList.homogeneous [la1; la2; nu3] then begin && ThoList.homogeneous [la1; la2; nu3] then begin
if ThoList.homogeneous [q1; minus_two q2; minus_two q3] then if ThoList.homogeneous [q1; minus_two q2; minus_two q3] then
(q1, Coupling.Vector4 [ ( 2, Coupling.C_12_34); (p, q1, Coupling.Vector4 [ ( 2, Coupling.C_12_34);
(-1, Coupling.C_13_42); (-1, Coupling.C_13_42);
(-1, Coupling.C_14_23) ]) (-1, Coupling.C_14_23) ])
else if ThoList.homogeneous [q2; minus_two q3; minus_two q1] then else if ThoList.homogeneous [q2; minus_two q3; minus_two q1] then
(q2, Coupling.Vector4 [ (-1, Coupling.C_12_34); (p, q2, Coupling.Vector4 [ (-1, Coupling.C_12_34);
( 2, Coupling.C_13_42); ( 2, Coupling.C_13_42);
(-1, Coupling.C_14_23) ] ) (-1, Coupling.C_14_23) ] )
else if ThoList.homogeneous [q3; minus_two q1; minus_two q2] then else if ThoList.homogeneous [q3; minus_two q1; minus_two q2] then
(q3, Coupling.Vector4 [ (-1, Coupling.C_12_34); (p, q3, Coupling.Vector4 [ (-1, Coupling.C_12_34);
(-1, Coupling.C_13_42); (-1, Coupling.C_13_42);
( 2, Coupling.C_14_23) ]) ( 2, Coupling.C_14_23) ])
else begin else begin
prerr_endline prerr_endline
("unexpected 4-gauge-vertex: " ^ UFOx.Lorentz.to_string t); ("unexpected 4-gauge-vertex: " ^ UFOx.Lorentz.to_string t);
(Q.unit, dummy_tensor4) (p, Q.unit, dummy_tensor4)
end end
end else begin end else begin
prerr_endline prerr_endline
...@@ -1527,14 +1531,14 @@ i.e. ...@@ -1527,14 +1531,14 @@ i.e.
[1;3;2;4] - [1;4;2;3] *) [1;3;2;4] - [1;4;2;3] *)
if mu1 = mu2 && q2 = Q.neg q1 then begin if mu1 = mu2 && q2 = Q.neg q1 then begin
if [nu2; ka2; la2] = [ka1; nu1; la1] then if [nu2; ka2; la2] = [ka1; nu1; la1] then
(q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34); (p, q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34);
(-1, Coupling.C_13_42) ]) (-1, Coupling.C_13_42) ])
else if [nu2; ka2; la2] = [la1; nu1; ka1] then else if [nu2; ka2; la2] = [la1; nu1; ka1] then
(q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34); (p, q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34);
(-1, Coupling.C_14_23) ]) (-1, Coupling.C_14_23) ])
else if [nu2; ka2; la2] = [la1; ka1; nu1] then else if [nu2; ka2; la2] = [la1; ka1; nu1] then
(q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34); (p, q1, Coupling.Vector4 [ ( 1, Coupling.C_12_34);
(-1, Coupling.C_14_23) ]) (-1, Coupling.C_14_23) ])
else else
invalid_arg "translate_lorentz_4: inconsistent" invalid_arg "translate_lorentz_4: inconsistent"
end else end else
...@@ -1542,9 +1546,21 @@ i.e. ...@@ -1542,9 +1546,21 @@ i.e.
| _ -> failwith "translate_lorentz_4: unexpected" | _ -> failwith "translate_lorentz_4: unexpected"
end end
| [ ([L.Metric(mu,nu)], q) ] -> | [ ([L.Metric(mu,nu)], q) ] ->
prerr_endline let mu' = mu - 1
("incompletely handled seagull-vertex: " ^ UFOx.Lorentz.to_string t); and nu' = nu - 1 in
(Q.unit, Coupling.Scalar2_Vector2 1) (* TODO: generalize this! *)
let vectors_last ka la =
if ka = la then
0
else if (ka = mu' || ka = nu') && la != mu' && la != nu' then
1
else if (la = mu' || la = nu') && ka != mu' && ka != nu' then
-1
else
compare ka la in
let p' = p in
Array.sort vectors_last p';
(p', Q.unit, Coupling.Scalar2_Vector2 1)
| _ -> failwith "translate_lorentz_4" | _ -> failwith "translate_lorentz_4"
let translate_coupling4 model p t c g = let translate_coupling4 model p t c g =
...@@ -1556,7 +1572,7 @@ i.e. ...@@ -1556,7 +1572,7 @@ i.e.
dummy_constant) dummy_constant)
| [| t |], qc, [| [| g |] |] -> | [| t |], qc, [| [| g |] |] ->
begin match translate_lorentz_4 model p t with begin match translate_lorentz_4 model p t with
| q, t -> ((p.(0), p.(1), p.(2), p.(3)), t, dummy_constant) | p, q, t -> ((p.(0), p.(1), p.(2), p.(3)), t, dummy_constant)
end end
| [| t |], qc, _-> | [| t |], qc, _->
invalid_arg "translate_coupling4: too many constants" invalid_arg "translate_coupling4: too many constants"
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment