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

ThoList.lexicographic

parent 628ecf6b
......@@ -395,19 +395,19 @@ let insert_inorder_signed order x (eps, l) =
in
insert 1 [] l
let sort_signed order l =
List.fold_right (insert_inorder_signed order) l (1, [])
let sort_signed ?(cmp=Pervasives.compare) l =
List.fold_right (insert_inorder_signed cmp) l (1, [])
let sign order l =
let eps, _ = sort_signed order l in
let sign ?(cmp=Pervasives.compare) l =
let eps, _ = sort_signed ~cmp l in
eps
let sign2 order l =
let sign2 ?(cmp=Pervasives.compare) l =
let a = Array.of_list l in
let eps = ref 1 in
for j = 0 to Array.length a - 1 do
for i = 0 to j - 1 do
if compare a.(i) a.(j) > 0 then
if cmp a.(i) a.(j) > 0 then
eps := - !eps
done
done;
......@@ -424,19 +424,19 @@ module Test =
assert_raises
(Invalid_argument
"Combinatorics.insert_inorder_signed: identical elements")
(fun () -> sort_signed compare [1;2;3;4;2]))
(fun () -> sort_signed [1;2;3;4;2]))
let sort_signed_even =
"even" >::
(fun () ->
assert_equal (1, [1;2;3;4;5;6])
(sort_signed compare [1;2;4;3;6;5]))
(sort_signed [1;2;4;3;6;5]))
let sort_signed_odd =
"odd" >::
(fun () ->
assert_equal (-1, [1;2;3;4;5;6])
(sort_signed compare [2;3;1;5;4;6]))
(sort_signed [2;3;1;5;4;6]))
let sort_signed_all =
"all" >::
......@@ -445,7 +445,7 @@ module Test =
assert_bool "all signed permutations"
(List.for_all
(fun (eps, p) ->
let eps', p' = sort_signed compare p in
let eps', p' = sort_signed p in
eps' = eps && p' = l)
(permute_signed l)))
......@@ -455,7 +455,7 @@ module Test =
let l = ThoList.range 1 8in
assert_bool "all permutations"
(List.for_all
(fun p -> sign compare p = sign2 compare p)
(fun p -> sign p = sign2 p)
(permute l)))
let suite_sort_signed =
......
......@@ -152,11 +152,11 @@ val permute_tensor_signed : 'a seq list -> (int * 'a seq list) list
val permute_tensor_even : 'a seq list -> 'a seq list list
val permute_tensor_odd : 'a seq list -> 'a seq list list
val sign : ('a -> 'a -> int) -> 'a seq -> int
val sign : ?cmp:('a -> 'a -> int) -> 'a seq -> int
(* \thocwmodulesubsection{Sorting} *)
val sort_signed : ('a -> 'a -> int) -> 'a seq -> int * 'a seq
val sort_signed : ?cmp:('a -> 'a -> int) -> 'a seq -> int * 'a seq
(* \thocwmodulesubsection{Unit Tests} *)
......
......@@ -370,7 +370,7 @@ i*)
dependencies' node
let lists dag =
Sort.list (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2 <= 0)
List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2)
(Parents.fold (fun node offspring l ->
(node, Offspring.elements offspring) :: l) dag [])
......@@ -436,7 +436,7 @@ i*)
List.fold_left
(fun (v, values) -> eval_offspring f mule muln add null unit dag values)
(null, Parents.empty)
(Sort.list (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2 <= 0)
(List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2)
(Parents.fold
(fun node offspring l -> (node, offspring) :: l) dag [])) in
result
......
......@@ -201,8 +201,8 @@ module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) =
let permutation lines =
let fout, fin = List.split lines in
let eps_in, _ = Combinatorics.sort_signed compare fin
and eps_out, _ = Combinatorics.sort_signed compare fout in
let eps_in, _ = Combinatorics.sort_signed fin
and eps_out, _ = Combinatorics.sort_signed fout in
(eps_in * eps_out)
(* \begin{dubious}
......@@ -1990,7 +1990,7 @@ i*)
raise Impossible
i*)
let permutation lines = fst(Combinatorics.sort_signed compare lines)
let permutation lines = fst (Combinatorics.sort_signed lines)
let stat_sign = function
| Boson lines -> permutation lines
......
......@@ -295,6 +295,19 @@ let ariadne_unsort (sorted, indices) =
(fun (n1, a1) (n2, a2) -> Pervasives.compare n1 n2)
(List.map2 (fun n a -> (n, a)) indices sorted))
let lexicographic ?(cmp=Pervasives.compare) l1 l2 =
let rec lexicographic' = function
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| x1 :: rest1, x2 :: rest2 ->
let res = cmp x1 x2 in
if res <> 0 then
res
else
lexicographic' (rest1, rest2) in
lexicographic' (l1, l2)
let common l1 l2 =
List.fold_left
(fun acc x1 ->
......
......@@ -132,6 +132,10 @@ val ariadne_sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list * int list
(* [ariadne_unsort (ariadne_sort cmp list)] returns [list]. *)
val ariadne_unsort : 'a list * int list -> 'a list
(* [lexicographic cmp list1 list2] compares [list1] and [list2]
lexicographically. *)
val lexicographic : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
(* [common l1 l2] returns the elements common to the lists [l1] and [l2]. *)
val common : 'a list -> 'a list -> 'a list
......
......@@ -1079,7 +1079,7 @@ module Model =
match c with
| Identity (i, j) -> 1
| T (a, i, j) -> 1
| F (a, b, c) -> Combinatorics.sign compare [a;b;c]
| F (a, b, c) -> Combinatorics.sign [a;b;c]
| D (a, b, c) -> invalid_arg "d-tensor not supported yet"
| Epsilon (i, j, k) -> invalid_arg "epsilon-tensor not supported yet"
| EpsilonBar (i, j, k) -> invalid_arg "epsilon-tensor not supported yet"
......@@ -1161,8 +1161,8 @@ module Model =
1
else
compare i i' in
begin match (Combinatorics.sort_signed order abc,
Combinatorics.sort_signed order abc') with
begin match (Combinatorics.sort_signed abc,
Combinatorics.sort_signed abc') with
| (eps, [_; b; c]), (eps', [_; b'; c']) ->
let a, b, c, d = normalize_quartet b c b' c' in
FF_1 (Q.make (eps * eps') 1, a, b, c, d)
......@@ -1256,15 +1256,15 @@ i.e.
let bcd1 = [b1; c1; d1]
and bcd2 = [b2; c2; d2]
and bcd3 = [b3; c3; d3] in
let eps1 = Combinatorics.sign compare bcd1 in
let eps1 = Combinatorics.sign bcd1 in
let eps2, bcd2 =
let eps = Combinatorics.sign compare bcd2 in
let eps = Combinatorics.sign bcd2 in
if eps = eps1 then
(Q.make eps 1, bcd2)
else
(Q.make eps 1, [b2; d2; c2])
and eps3, bcd3 =
let eps = Combinatorics.sign compare bcd3 in
let eps = Combinatorics.sign bcd3 in
if eps = eps1 then
(Q.make eps 1, bcd3)
else
......@@ -1290,24 +1290,17 @@ i.e.
(Printf.sprintf
"translate_color4: #color structures: %d" (Array.length c))
let order_lexicographic order l1 l2 =
let rec order_lexicographic' = function
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| x1 :: rest1, x2 :: rest2 ->
let res = order x1 x2 in
if res <> 0 then
res
else
order_lexicographic' (rest1, rest2) in
order_lexicographic' (l1, l2)
(* The Lorentz part of the thre gauge boson vertex is
\begin{equation}
g_{\mu_1\mu_2} (k^1_{\mu_3} - k^2_{\mu_3})
+ g_{\mu_2\mu_3} (k^2_{\mu_1} - k^3_{\mu_1})
+ g_{\mu_3\mu_1} (k^3_{\mu_2} - k^1_{\mu_2})
\end{equation}
*)
let normalize_lorentz_gauge_3 l =
List.sort
(fun (ka1, la1, mu1, i1, q1) (ka2, la2, mu2, i2, q2) ->
order_lexicographic compare
[ka1; la1; mu1; i1] [ka2; la2; mu2; i2])
ThoList.lexicographic [ka1; la1; mu1; i1] [ka2; la2; mu2; i2])
(List.map
(fun (ka, la, mu, i, q) ->
if ka > la then
......@@ -1316,12 +1309,6 @@ i.e.
(ka, la, mu, i, q))
l)
(* \begin{equation}
g_{\mu_1\mu_2} (k^1_{\mu_3} - k^2_{\mu_3})
+ g_{\mu_2\mu_3} (k^2_{\mu_1} - k^3_{\mu_1})
+ g_{\mu_3\mu_1} (k^3_{\mu_2} - k^1_{\mu_2})
\end{equation}
*)
let translate_lorentz_gauge_3 t p kalamuiq =
match normalize_lorentz_gauge_3 kalamuiq with
| [ (ka1, la1, mu1, i1, q1);
......@@ -1480,12 +1467,12 @@ i.e.
| _ -> failwith "translate_lorentz_4_1"
let normalize_lorentz_4_1 (mu, nu, ka, la) =
List.flatten (List.sort (order_lexicographic compare)
List.flatten (List.sort ThoList.lexicographic
(List.map (List.sort compare) [[mu; nu]; [ka; la]]))
let normalize_lorentz_4 contractions =
List.sort
(fun (c1, q1) (c2, q2) -> order_lexicographic compare c1 c2)
(fun (c1, q1) (c2, q2) -> ThoList.lexicographic c1 c2)
(List.map (fun (c, q) -> (normalize_lorentz_4_1 c, q)) contractions)
let translate_lorentz_4 model p t =
......
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