Index: trunk/omega/src/color.ml =================================================================== --- trunk/omega/src/color.ml (revision 8305) +++ trunk/omega/src/color.ml (revision 8306) @@ -1,2110 +1,2114 @@ (* color.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + (* \thocwmodulesection{Quantum Numbers} *) type t = | Singlet | SUN of int | AdjSUN of int let conjugate = function | Singlet -> Singlet | SUN n -> SUN (-n) | AdjSUN n -> AdjSUN n let compare c1 c2 = match c1, c2 with | Singlet, Singlet -> 0 | Singlet, _ -> -1 | _, Singlet -> 1 | SUN n, SUN n' -> compare n n' | SUN _, AdjSUN _ -> -1 | AdjSUN _, SUN _ -> 1 | AdjSUN n, AdjSUN n' -> compare n n' module type Line = sig type t val conj : t -> t val equal : t -> t -> bool val to_string : t -> string end module type Cycles = sig type line type t = (line * line) list (* Contract the graph by connecting lines and return the number of cycles together with the contracted graph. \begin{dubious} The semantics of the contracted graph is not yet 100\%ly fixed. \end{dubious} *) val contract : t -> int * t (* The same as [contract], but returns only the number of cycles and raises [Open_line] when not all lines are closed. *) val count : t -> int exception Open_line (* Mainly for debugging \ldots *) val to_string : t -> string end module Cycles (L : Line) : Cycles with type line = L.t = struct type line = L.t type t = (line * line) list exception Open_line (* NB: The following algorithm for counting the cycles is quadratic since it performs nested scans of the lists. If this was a serious problem one could replace the lists of pairs by a [Map] and replace one power by a logarithm. *) let rec find_fst c_final c1 disc seen = function | [] -> ((L.conj c_final, c1) :: disc, List.rev seen) | (c1', c2') as c12' :: rest -> if L.equal c1 c1' then find_snd c_final (L.conj c2') disc [] (List.rev_append seen rest) else find_fst c_final c1 disc (c12' :: seen) rest and find_snd c_final c2 disc seen = function | [] -> ((L.conj c_final, L.conj c2) :: disc, List.rev seen) | (c1', c2') as c12' :: rest-> if L.equal c2' c2 then begin if L.equal c1' c_final then (disc, List.rev_append seen rest) else find_fst c_final (L.conj c1') disc [] (List.rev_append seen rest) end else find_snd c_final c2 disc (c12' :: seen) rest let consume = function | [] -> ([], []) | (c1, c2) :: rest -> find_snd (L.conj c1) (L.conj c2) [] [] rest let contract lines = let rec contract' acc disc = function | [] -> (acc, List.rev disc) | rest -> begin match consume rest with | [], rest' -> contract' (succ acc) disc rest' | disc', rest' -> contract' acc (List.rev_append disc' disc) rest' end in contract' 0 [] lines let count lines = match contract lines with | n, [] -> n | n, _ -> raise Open_line let to_string lines = String.concat "" (List.map (fun (c1, c2) -> "[" ^ L.to_string c1 ^ "," ^ L.to_string c2 ^ "]") lines) end (* \thocwmodulesection{Color Flows} *) module type Flow = sig type color type t = color list * color list val rank : t -> int val of_list : int list -> color val ghost : unit -> color val to_lists : t -> int list list val in_to_lists : t -> int list list val out_to_lists : t -> int list list val ghost_flags : t -> bool list val in_ghost_flags : t -> bool list val out_ghost_flags : t -> bool list type power = { num : int; den : int; power : int } type factor = power list val factor : t -> t -> factor val zero : factor end module Flow : Flow = struct type color = | Lines of int * int | Ghost type t = color list * color list let rank cflow = 2 (* \thocwmodulesubsection{Constructors} *) let ghost () = Ghost let of_list = function | [c1; c2] -> Lines (c1, c2) | _ -> invalid_arg "Color.Flow.of_list: num_lines != 2" let to_list = function | Lines (c1, c2) -> [c1; c2] | Ghost -> [0; 0] let to_lists (cfin, cfout) = (List.map to_list cfin) @ (List.map to_list cfout) let in_to_lists (cfin, _) = List.map to_list cfin let out_to_lists (_, cfout) = List.map to_list cfout let ghost_flag = function | Lines _ -> false | Ghost -> true let ghost_flags (cfin, cfout) = (List.map ghost_flag cfin) @ (List.map ghost_flag cfout) let in_ghost_flags (cfin, _) = List.map ghost_flag cfin let out_ghost_flags (_, cfout) = List.map ghost_flag cfout (* \thocwmodulesubsection{Evaluation} *) type power = { num : int; den : int; power : int } type factor = power list let zero = [] let count_ghosts1 colors = List.fold_left (fun acc -> function Ghost -> succ acc | _ -> acc) 0 colors let count_ghosts (fin, fout) = count_ghosts1 fin + count_ghosts1 fout type 'a square = | Square of 'a | Mismatch let conjugate = function | Lines (c1, c2) -> Lines (-c2, -c1) | Ghost -> Ghost let cross_in (cin, cout) = cin @ (List.map conjugate cout) let cross_out (cin, cout) = (List.map conjugate cin) @ cout module C = Cycles (struct type t = int let conj = (~-) let equal = (=) let to_string = string_of_int end) let square f1 f2 = let rec square' acc f1' f2' = match f1', f2' with | [], [] -> Square (List.rev acc) | _, [] | [], _ -> Mismatch | Ghost :: rest1, Ghost :: rest2 -> square' acc rest1 rest2 | Lines (0, 0) :: rest1, Lines (0, 0) :: rest2 -> square' acc rest1 rest2 | Lines (0, c1') :: rest1, Lines (0, c2') :: rest2 -> square' ((c1', c2') :: acc) rest1 rest2 | Lines (c1, 0) :: rest1, Lines (c2, 0) :: rest2 -> square' ((c1, c2) :: acc) rest1 rest2 | Lines (0, _) :: _, _ | _ , Lines (0, _) :: _ | Lines (_, 0) :: _, _ | _, Lines (_, 0) :: _ -> Mismatch | Lines (_, _) :: _, Ghost :: _ | Ghost :: _, Lines (_, _) :: _ -> Mismatch | Lines (c1, c1') :: rest1, Lines (c2, c2') :: rest2 -> square' ((c1', c2') :: (c1, c2) :: acc) rest1 rest2 in square' [] (cross_out f1) (cross_out f2) (* In addition to counting closed color loops, we also need to count closed gluon loops. Fortunately, we can use the same algorithm on a different data type, provided it doesn't require all lines to be closed. *) module C2 = Cycles (struct type t = int * int let conj (c1, c2) = (- c2, - c1) let equal (c1, c2) (c1', c2') = c1 = c1' && c2 = c2' let to_string (c1, c2) = "(" ^ string_of_int c1 ^ "," ^ string_of_int c2 ^ ")" end) let square2 f1 f2 = let rec square2' acc f1' f2' = match f1', f2' with | [], [] -> Square (List.rev acc) | _, [] | [], _ -> Mismatch | Ghost :: rest1, Ghost :: rest2 -> square2' acc rest1 rest2 | Lines (0, 0) :: rest1, Lines (0, 0) :: rest2 -> square2' acc rest1 rest2 | Lines (0, _) :: rest1, Lines (0, _) :: rest2 | Lines (_, 0) :: rest1, Lines (_, 0) :: rest2 -> square2' acc rest1 rest2 | Lines (0, _) :: _, _ | _ , Lines (0, _) :: _ | Lines (_, 0) :: _, _ | _, Lines (_, 0) :: _ -> Mismatch | Lines (_, _) :: _, Ghost :: _ | Ghost :: _, Lines (_, _) :: _ -> Mismatch | Lines (c1, c1') :: rest1, Lines (c2, c2') :: rest2 -> square2' (((c1, c1'), (c2, c2')) :: acc) rest1 rest2 in square2' [] (cross_out f1) (cross_out f2) (* $\ocwlowerid{int\_power}: n\, p \to n^p$ for integers is missing from [Pervasives]! *) let int_power n p = let rec int_power' acc i = if i < 0 then invalid_arg "int_power" else if i = 0 then acc else int_power' (n * acc) (pred i) in int_power' 1 p (* Instead of implementing a full fledged algebraic evaluator, let's simply expand the binomial by hand: \begin{equation} \left(\frac{N_C^2-2}{N_C^2}\right)^n = \sum_{i=0}^n \binom{n}{i} (-2)^i N_C^{-2i} \end{equation} *) (* NB: Any result of [square] other than [Mismatch] guarantees [count_ghosts f1 = count_ghosts f2]. *) let factor f1 f2 = match square f1 f2, square2 f1 f2 with | Mismatch, _ | _, Mismatch -> [] | Square f12, Square f12' -> let num_cycles = C.count f12 and num_cycles2, disc = C2.contract f12' and num_ghosts = count_ghosts f1 in (*i Printf.eprintf "f12 = %s -> #loops = %d\n" (C.to_string f12) num_cycles; Printf.eprintf "f12' = %s -> #loops = %d, disc = %s\n" (C2.to_string f12') num_cycles2 (C2.to_string disc); flush stderr; i*) List.map (fun i -> let parity = if num_ghosts mod 2 = 0 then 1 else -1 and power = num_cycles - num_ghosts in let coeff = int_power (-2) i * Combinatorics.binomial num_cycles2 i and power2 = - 2 * i in { num = parity * coeff; den = 1; power = power + power2 }) (ThoList.range 0 num_cycles2) end (* later: *) module General_Flow = struct type color = | Lines of int list | Ghost of int type t = color list * color list let rank_default = 2 (* Standard model *) let rank cflow = try begin match List.hd cflow with | Lines lines -> List.length lines | Ghost n_lines -> n_lines end with | _ -> rank_default end (* \thocwmodulesection{Vertex Color Flows} *) module Q = Algebra.Q module QC = Algebra.QC module type Test = sig val suite : OUnit.test end module type Arrow = sig type endpoint val position : endpoint -> int val relocate : (int -> int) -> endpoint -> endpoint type tip = endpoint type tail = endpoint type ghost = endpoint type ('tail, 'tip, 'ghost) t = | Arrow of 'tail * 'tip | Ghost of 'ghost type free = (tail, tip, ghost) t type factor val free_to_string : free -> string val factor_to_string : factor -> string val map : (endpoint -> endpoint) -> free -> free val to_left_factor : (endpoint -> bool) -> free -> factor val to_right_factor : (endpoint -> bool) -> free -> factor val of_factor : factor -> free val negatives : free -> endpoint list val is_free : factor -> bool val is_ghost : free -> bool val single : endpoint -> endpoint -> free val double : endpoint -> endpoint -> free list val ghost : endpoint -> free val chain : int list -> free list val cycle : int list -> free list type merge = | Match of factor | Ghost_Match | Loop_Match | Mismatch | No_Match val merge : factor -> factor -> merge module BinOps : sig val (=>) : int -> int -> free val (==>) : int -> int -> free list val (<=>) : int -> int -> free list val (>=>) : int * int -> int -> free val (=>>) : int -> int * int -> free val (>=>>) : int * int -> int * int -> free val (??) : int -> free end module Test : Test end module Arrow : Arrow = struct type endpoint = | I of int | M of int * int let position = function | I i -> i | M (i, _) -> i let relocate f = function | I i -> I (f i) | M (i, n) -> M (f i, n) type tip = endpoint type tail = endpoint type ghost = endpoint (* Note that the \emph{same} index can appear multiple times on in \emph{each} side. Thus, we \emph{must not} combine the arrows in the two factors. In fact, we cannot disambiguate them by distinguishing tips from tails alone. *) type 'a index = | Free of 'a | SumL of 'a | SumR of 'a type ('tail, 'tip, 'ghost) t = | Arrow of 'tail * 'tip | Ghost of 'ghost type free = (tail, tip, ghost) t type factor = (tail index, tip index, ghost index) t let endpoint_to_string = function | I i -> string_of_int i | M (i, n) -> Printf.sprintf "%d.%d" i n let index_to_string = function | Free i -> endpoint_to_string i | SumL i -> endpoint_to_string i ^ "L" | SumR i -> endpoint_to_string i ^ "R" let to_string i2s = function | Arrow (tail, tip) -> Printf.sprintf "%s>%s" (i2s tail) (i2s tip) | Ghost ghost -> Printf.sprintf "{%s}" (i2s ghost) let free_to_string = to_string endpoint_to_string let factor_to_string = to_string index_to_string let index_matches i1 i2 = match i1, i2 with | SumL i1, SumR i2 | SumR i1, SumL i2 -> i1 = i2 | _ -> false let map f = function | Arrow (tail, tip) -> Arrow (f tail, f tip) | Ghost ghost -> Ghost (f ghost) let free_index = function | Free i -> i | SumL i -> invalid_arg "Color.Arrow.free_index: leftover LHS summation" | SumR i -> invalid_arg "Color.Arrow.free_index: leftover RHS summation" let to_left_index is_sum i = if is_sum i then SumL i else Free i let to_right_index is_sum i = if is_sum i then SumR i else Free i let to_left_factor is_sum = map (to_left_index is_sum) let to_right_factor is_sum = map (to_right_index is_sum) let of_factor = map free_index let negatives = function | Arrow (tail, tip) -> if position tail < 0 then if position tip < 0 then [tail; tip] else [tail] else if position tip < 0 then [tip] else [] | Ghost ghost -> if position ghost < 0 then [ghost] else [] let is_free = function | Arrow (Free _, Free _) | Ghost (Free _) -> true | _ -> false let is_ghost = function | Ghost _ -> true | Arrow _ -> false let single tail tip = Arrow (tail, tip) let double a b = if a = b then [single a b] else [single a b; single b a] let ghost g = Ghost g type merge = | Match of factor | Ghost_Match | Loop_Match | Mismatch | No_Match let merge arrow1 arrow2 = match arrow1, arrow2 with | Ghost g1, Ghost g2 -> if index_matches g1 g2 then Ghost_Match else No_Match | Arrow (tail, tip), Ghost g | Ghost g, Arrow (tail, tip) -> if index_matches g tail || index_matches g tip then Mismatch else No_Match | Arrow (tail, tip), Arrow (tail', tip') -> if index_matches tip tail' then if index_matches tip' tail then Loop_Match else Match (Arrow (tail, tip')) else if index_matches tip' tail then Match (Arrow (tail', tip)) else No_Match module BinOps = struct let (=>) i j = single (I i) (I j) let (==>) i j = [i => j] let (<=>) i j = double (I i) (I j) let ( >=> ) (i, n) j = single (M (i, n)) (I j) let ( =>> ) i (j, m) = single (I i) (M (j, m)) let ( >=>> ) (i, n) (j, m) = single (M (i, n)) (M (j, m)) (* I wanted to use [~~] instead of [??], but ocamlweb doesn't like operators starting with [~] in the index. *) let (??) i = ghost (I i) end open BinOps (* Composite Arrows. *) let rec chain' = function | [] -> [] | [a] -> [a => a] | [a; b] -> [a => b] | a :: (b :: _ as rest) -> (a => b) :: chain' rest let chain = function | [] -> [] | a :: _ as a_list -> chain' a_list let rec cycle' a = function | [] -> [a => a] | [b] -> [b => a] | b :: (c :: _ as rest) -> (b => c) :: cycle' a rest let cycle = function | [] -> [] | a :: _ as a_list -> cycle' a a_list module Test : Test = struct open OUnit let suite_chain = "chain" >::: [ "chain []" >:: (fun () -> assert_equal [] (chain [])); "chain [1]" >:: (fun () -> assert_equal [1 => 1] (chain [1])); "chain [1;2]" >:: (fun () -> assert_equal [1 => 2] (chain [1; 2])); "chain [1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3] (chain [1; 2; 3])); "chain [1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4] (chain [1; 2; 3; 4])) ] let suite_cycle = "cycle" >::: [ "cycle []" >:: (fun () -> assert_equal [] (cycle [])); "cycle [1]" >:: (fun () -> assert_equal [1 => 1] (cycle [1])); "cycle [1;2]" >:: (fun () -> assert_equal [1 => 2; 2 => 1] (cycle [1; 2])); "cycle [1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 1] (cycle [1; 2; 3])); "cycle [1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4; 4 => 1] (cycle [1; 2; 3; 4])) ] let suite = "Color.Arrow" >::: [suite_chain; suite_cycle] end end module type Propagator = sig type cf_in = int type cf_out = int type t = W | I of cf_in | O of cf_out | IO of cf_in * cf_out | G val to_string : t -> string end module Propagator : Propagator = struct type cf_in = int type cf_out = int type t = W | I of cf_in | O of cf_out | IO of cf_in * cf_out | G let to_string = function | W -> "W" | I cf -> Printf.sprintf "I(%d)" cf | O cf' -> Printf.sprintf "O(%d)" cf' | IO (cf, cf') -> Printf.sprintf "IO(%d,%d)" cf cf' | G -> "G" end module type LP = sig val rationals : (Algebra.Q.t * int) list -> Algebra.Laurent.t val ints : (int * int) list -> Algebra.Laurent.t val rational : Algebra.Q.t -> Algebra.Laurent.t val int : int -> Algebra.Laurent.t val fraction : int -> Algebra.Laurent.t val imag : int -> Algebra.Laurent.t val nc : int -> Algebra.Laurent.t val over_nc : int -> Algebra.Laurent.t end module LP : LP = struct module L = Algebra.Laurent (* Rationals from integers. *) let q_int n = Q.make n 1 let q_fraction n = Q.make 1 n (* Complex rationals: *) let qc_rational q = QC.make q Q.null let qc_int n = qc_rational (q_int n) let qc_fraction n = qc_rational (q_fraction n) let qc_imag n = QC.make Q.null (q_int n) (* Laurent polynomials: *) let of_pairs f pairs = L.sum (List.map (fun (coeff, power) -> L.atom (f coeff) power) pairs) let rationals = of_pairs qc_rational let ints = of_pairs qc_int let rational q = rationals [(q, 0)] let int n = ints [(n, 0)] let fraction n = L.const (qc_fraction n) let imag n = L.const (qc_imag n) let nc n = ints [(n, 1)] let over_nc n = ints [(n, -1)] end module type Birdtracks = sig type t val to_string : t -> string val pp : Format.formatter -> t -> unit val trivial : t -> bool val is_null : t -> bool val unit : t val null : t val two : t val half : t val third : t val minus : t val nc : t val imag : t val ints : (int * int) list -> t val const : Algebra.Laurent.t -> t val times : t -> t -> t val multiply : t list -> t val scale : Q.t -> t -> t val sum : t list -> t val diff : t -> t -> t val f_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t val d_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t module BinOps : sig val ( +++ ) : t -> t -> t val ( --- ) : t -> t -> t val ( *** ) : t -> t -> t end val map : (int -> int) -> t -> t val fuse : int -> t -> Propagator.t list -> (QC.t * Propagator.t) list module Test : Test end module Birdtracks = struct module A = Arrow open A.BinOps module P = Propagator module L = Algebra.Laurent type connection = L.t * A.free list type t = connection list let trivial = function | [] -> true | [(coeff, [])] -> coeff = L.unit | _ -> false (* Rationals from integers. *) let q_int n = Q.make n 1 let q_fraction n = Q.make 1 n (* Complex rationals: *) let qc_rational q = QC.make q Q.null let qc_int n = qc_rational (q_int n) let qc_fraction n = qc_rational (q_fraction n) let qc_imag n = QC.make Q.null (q_int n) (* Laurent polynomials: *) let laurent_of_pairs f pairs = L.sum (List.map (fun (coeff, power) -> L.atom (f coeff) power) pairs) let l_rationals = laurent_of_pairs qc_rational let l_ints = laurent_of_pairs qc_int let l_rational q = l_rationals [(q, 0)] let l_int n = l_ints [(n, 0)] let l_fraction n = L.const (qc_fraction n) let l_imag n = L.const (qc_imag n) let l_nc n = l_ints [(n, 1)] let l_over_nc n = l_ints [(n, -1)] (* Expressions *) let unit = [] let const c = [c, []] let ints pairs = const (LP.ints pairs) let null = const L.null let half = const (LP.fraction 2) let third = const (LP.fraction 3) let two = const (LP.int 2) let minus = const (LP.int (-1)) let nc = const (LP.nc 1) let imag = const (LP.imag 1) module AMap = Pmap.Tree let find_arrows_opt arrows map = - try Some (AMap.find Pervasives.compare arrows map) with Not_found -> None + try Some (AMap.find pcompare arrows map) with Not_found -> None let canonicalize1 (coeff, io_list) = - (coeff, List.sort Pervasives.compare io_list) + (coeff, List.sort pcompare io_list) let canonicalize terms = let map = List.fold_left (fun acc term -> let coeff, arrows = canonicalize1 term in if coeff = L.null then acc else match find_arrows_opt arrows acc with - | None -> AMap.add Pervasives.compare arrows coeff acc + | None -> AMap.add pcompare arrows coeff acc | Some coeff' -> let coeff'' = L.add coeff coeff' in if coeff'' = L.null then - AMap.remove Pervasives.compare arrows acc + AMap.remove pcompare arrows acc else - AMap.add Pervasives.compare arrows coeff'' acc) + AMap.add pcompare arrows coeff'' acc) AMap.empty terms in if AMap.is_empty map then null else AMap.fold (fun arrows coeff acc -> (coeff, arrows) :: acc) map [] let arrows_to_string_aux f arrows = ThoList.to_string f arrows let to_string1_aux f (coeff, arrows) = Printf.sprintf "(%s) * %s" (L.to_string "N" coeff) (arrows_to_string_aux f arrows) let to_string1_opt_aux f = function | None -> "None" | Some v -> to_string1_aux f v let to_string_raw_aux f v = ThoList.to_string (to_string1_aux f) v let to_string_aux f v = to_string_raw_aux f (canonicalize v) let factor_arrows_to_string = arrows_to_string_aux A.factor_to_string let factor_to_string1 = to_string1_aux A.factor_to_string let factor_to_string1_opt = to_string1_opt_aux A.factor_to_string let factor_to_string_raw = to_string_raw_aux A.factor_to_string let factor_to_string = to_string_aux A.factor_to_string let arrows_to_string = arrows_to_string_aux A.free_to_string let to_string1 = to_string1_aux A.free_to_string let to_string1_opt = to_string1_opt_aux A.free_to_string let to_string_raw = to_string_raw_aux A.free_to_string let to_string = to_string_aux A.free_to_string let pp fmt v = Format.fprintf fmt "%s" (to_string v) let is_null v = match canonicalize v with | [c, _] -> c = L.null | _ -> false let is_white = function | P.W -> true | _ -> false let map1 f (c, v) = (c, List.map (A.map (A.relocate f)) v) let map f = List.map (map1 f) let add_arrow arrow (coeff, arrows) = let rec add_arrow' arrow (coeff, acc) = function | [] -> (* No opportunities for further matches *) Some (coeff, arrow :: acc) | arrow' :: arrows' -> begin match A.merge arrow arrow' with | A.Mismatch -> None | A.Ghost_Match -> Some (L.mul (LP.over_nc (-1)) coeff, List.rev_append acc arrows') | A.Loop_Match -> Some (L.mul (LP.nc 1) coeff, List.rev_append acc arrows') | A.Match arrow'' -> if A.is_free arrow'' then Some (coeff, arrow'' :: List.rev_append acc arrows') else (* the new [arrow''] ist not yet saturated, try again: *) add_arrow' arrow'' (coeff, acc) arrows' | A.No_Match -> add_arrow' arrow (coeff, arrow' :: acc) arrows' end in add_arrow' arrow (coeff, []) arrows let logging_add_arrow arrow (coeff, arrows) = let result = add_arrow arrow (coeff, arrows) in Printf.eprintf "add_arrow %s to %s ==> %s\n" (A.factor_to_string arrow) (factor_to_string1 (coeff, arrows)) (factor_to_string1_opt result); result (* We can reject the contributions with unsaturated summation indices from Ghost contributions to~$T_a$ only \emph{after} adding all arrows that might saturate an open index. *) let add_arrows factor1 arrows2 = let rec add_arrows' (_, arrows as acc) = function | [] -> if List.for_all A.is_free arrows then Some acc else None | arrow :: arrows -> begin match add_arrow arrow acc with | None -> None | Some acc' -> add_arrows' acc' arrows end in add_arrows' factor1 arrows2 let logging_add_arrows factor1 arrows2 = let result = add_arrows factor1 arrows2 in Printf.eprintf "add_arrows %s to %s ==> %s\n" (factor_to_string1 factor1) (factor_arrows_to_string arrows2) (factor_to_string1_opt result); result (* Note that a negative index might be summed only later in a sequence of binary products and must therefore be treated as free in this product. Therefore, we have to classify the indices as summation indices \emph{not only} based on their sign, but in addition based on whether they appear in both factors. Only then can we reject surviving ghosts. *) module ESet = Set.Make (struct type t = A.endpoint - let compare = Pervasives.compare + let compare = pcompare end) let negatives arrows = List.fold_left (fun acc arrow -> List.fold_left (fun acc' i -> ESet.add i acc') acc (A.negatives arrow)) ESet.empty arrows let times1 (coeff1, arrows1) (coeff2, arrows2) = let summations = ESet.inter (negatives arrows1) (negatives arrows2) in let is_sum i = ESet.mem i summations in let arrows1' = List.map (A.to_left_factor is_sum) arrows1 and arrows2' = List.map (A.to_right_factor is_sum) arrows2 in match add_arrows (coeff1, arrows1') arrows2' with | None -> None | Some (coeff1, arrows) -> Some (L.mul coeff1 coeff2, List.map A.of_factor arrows) let logging_times1 factor1 factor2 = let result = times1 factor1 factor2 in Printf.eprintf "%s times1 %s ==> %s\n" (to_string1 factor1) (to_string1 factor2) (to_string1_opt result); result let sum terms = canonicalize (List.concat terms) let times term term' = canonicalize (Product.list2_opt times1 term term') (* \begin{dubious} Is that more efficient than the following implementation? \end{dubious} *) let rec multiply1' acc = function | [] -> Some acc | factor :: factors -> begin match times1 acc factor with | None -> None | Some acc' -> multiply1' acc' factors end let multiply1 = function | [] -> Some (L.unit, []) | [factor] -> Some factor | factor :: factors -> multiply1' factor factors let multiply termss = canonicalize (Product.list_opt multiply1 termss) (* \begin{dubious} Isn't that the more straightforward implementation? \end{dubious} *) let multiply = function | [] -> [] | term :: terms -> canonicalize (List.fold_left times term terms) let scale1 q (coeff, arrows) = (L.scale (qc_rational q) coeff, arrows) let scale q = List.map (scale1 q) let diff term1 term2 = canonicalize (List.rev_append term1 (scale (q_int (-1)) term2)) module BinOps = struct let ( +++ ) term term' = sum [term; term'] let ( --- ) = diff let ( *** ) = times end open BinOps let trace3 r a b c = r a (-1) (-2) *** r b (-2) (-3) *** r c (-3) (-1) let f_of_rep r a b c = minus *** imag *** (trace3 r a b c --- trace3 r a c b) let d_of_rep r a b c = trace3 r a b c +++ trace3 r a c b module IMap = - Map.Make (struct type t = int let compare = Pervasives.compare end) + Map.Make (struct type t = int let compare = pcompare end) let line_map lines = let _, map = List.fold_left (fun (i, acc) line -> (succ i, match line with | P.W -> acc | _ -> IMap.add i line acc)) (1, IMap.empty) lines in map let find_opt i map = try Some (IMap.find i map) with Not_found -> None let lines_to_string lines = match IMap.bindings lines with | [] -> "W" | lines -> String.concat " " (List.map (fun (i, c) -> Printf.sprintf "%s@%d" (P.to_string c) i) lines) let clear = IMap.remove let add_in i cf lines = match find_opt i lines with | Some (P.O cf') -> IMap.add i (P.IO (cf, cf')) lines | _ -> IMap.add i (P.I cf) lines let add_out i cf' lines = match find_opt i lines with | Some (P.I cf) -> IMap.add i (P.IO (cf, cf')) lines | _ -> IMap.add i (P.O cf') lines let add_ghost i lines = IMap.add i P.G lines let connect1 n arrow lines = match arrow with | A.Ghost g -> let g = A.position g in if g = n then Some (add_ghost n lines) else begin match find_opt g lines with | Some P.G -> Some (clear g lines) | _ -> None end | A.Arrow (i, o) -> let i = A.position i and o = A.position o in if o = n then match find_opt i lines with | Some (P.I cfi) -> Some (add_in o cfi (clear i lines)) | Some (P.IO (cfi, cfi')) -> Some (add_in o cfi (add_out i cfi' lines)) | _ -> None else if i = n then match find_opt o lines with | Some (P.O cfo') -> Some (add_out i cfo' (clear o lines)) | Some (P.IO (cfo, cfo')) -> Some (add_out i cfo' (add_in o cfo lines)) | _ -> None else match find_opt i lines, find_opt o lines with | Some (P.I cfi), Some (P.O cfo') when cfi = cfo' -> Some (clear o (clear i lines)) | Some (P.I cfi), Some (P.IO (cfo, cfo')) when cfi = cfo'-> Some (add_in o cfo (clear i lines)) | Some (P.IO (cfi, cfi')), Some (P.O cfo') when cfi = cfo' -> Some (add_out i cfi' (clear o lines)) | Some (P.IO (cfi, cfi')), Some (P.IO (cfo, cfo')) when cfi = cfo' -> Some (add_in o cfo (add_out i cfi' lines)) | _ -> None let connect connections lines = let n = succ (List.length lines) and lines = line_map lines in let rec connect' acc = function | arrow :: arrows -> begin match connect1 n arrow acc with | None -> None | Some acc -> connect' acc arrows end | [] -> Some acc in match connect' lines connections with | None -> None | Some acc -> begin match IMap.bindings acc with | [] -> Some P.W | [(i, cf)] when i = n -> Some cf | _ -> None end let fuse1 nc lines (c, vertex) = match connect vertex lines with | None -> [] | Some cf -> [(L.eval (qc_int nc) c, cf)] let fuse nc vertex lines = match vertex with | [] -> if List.for_all is_white lines then [(QC.one, P.W)] else [] | vertex -> ThoList.flatmap (fuse1 nc lines) vertex module Test : Test = struct open OUnit let vertices1_equal v1 v2 = match v1, v2 with | None, None -> true | Some v1, Some v2 -> (canonicalize1 v1) = (canonicalize1 v2) | _ -> false let assert_equal_vertices1 v1 v2 = assert_equal ~printer:to_string1_opt ~cmp:vertices1_equal v1 v2 let suite_times1 = "times1" >::: [ "merge two" >:: (fun () -> assert_equal_vertices1 (Some (L.unit, 1 ==> 2)) (times1 (L.unit, 1 ==> -1) (L.unit, -1 ==> 2))); "merge two exchanged" >:: (fun () -> assert_equal_vertices1 (Some (L.unit, 1 ==> 2)) (times1 (L.unit, -1 ==> 2) (L.unit, 1 ==> -1))); "ghost1" >:: (fun () -> assert_equal_vertices1 (Some (l_over_nc (-1), 1 ==> 2)) (times1 (L.unit, [-1 => 2; ?? (-3)]) (L.unit, [ 1 => -1; ?? (-3)]))); "ghost2" >:: (fun () -> assert_equal_vertices1 None (times1 (L.unit, [ 1 => -1; ?? (-3)]) (L.unit, [-1 => 2; -3 => -4; -4 => -3]))); "ghost2 exchanged" >:: (fun () -> assert_equal_vertices1 None (times1 (L.unit, [-1 => 2; -3 => -4; -4 => -3]) (L.unit, [ 1 => -1; ?? (-3)]))) ] let suite_canonicalize = "canonicalize" >::: [ ] let line_option_to_string = function | None -> "no match" | Some line -> P.to_string line let test_connect_msg vertex formatter (expected, result) = Format.fprintf formatter "[%s]: expected %s, got %s" (arrows_to_string vertex) (line_option_to_string expected) (line_option_to_string result) let test_connect expected lines vertex = assert_equal ~printer:line_option_to_string expected (connect vertex lines) let test_connect_permutations expected lines vertex = List.iter (fun v -> assert_equal ~pp_diff:(test_connect_msg v) expected (connect v lines)) (Combinatorics.permute vertex) let suite_connect = "connect" >::: [ "delta" >:: (fun () -> test_connect_permutations (Some (P.I 1)) [ P.I 1; P.W ] ( 1 ==> 3 )); "f: 1->3->2->1" >:: (fun () -> test_connect_permutations (Some (P.IO (1, 3))) [P.IO (1, 2); P.IO (2, 3)] (A.cycle [1; 3; 2])); "f: 1->2->3->1" >:: (fun () -> test_connect_permutations (Some (P.IO (1, 2))) [P.IO (3, 2); P.IO (1, 3)] (A.cycle [1; 2; 3])) ] let suite = "Color.Birdtracks" >::: [suite_times1; suite_canonicalize; suite_connect] end let vertices_equal v1 v2 = is_null (v1 --- v2) let assert_equal_vertices v1 v2 = OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal v1 v2 end (* \thocwmodulesubsection{$\mathrm{SU}(N_C)$} We're computing with a general $N_C$, but [epsilon] and [epsilonbar] make only sense for $N_C=3$. Also some of the terminology alludes to $N_C=3$: triplet, sextet, octet. *) module type SU3 = sig include Birdtracks val delta3 : int -> int -> t val delta8 : int -> int -> t val delta8_loop : int -> int -> t val gluon : int -> int -> t val t : int -> int -> int -> t val f : int -> int -> int -> t val d : int -> int -> int -> t val epsilon : int -> int -> int -> t val epsilonbar : int -> int -> int -> t val t6 : int -> int -> int -> t val k6 : int -> int -> int -> t val k6bar : int -> int -> int -> t end module SU3 : SU3 = struct module A = Arrow open Arrow.BinOps module B = Birdtracks type t = B.t let to_string = B.to_string let pp = B.pp let trivial = B.trivial let is_null = B.is_null let null = B.null let unit = B.unit let const = B.const let two = B.two let half = B.half let third = B.third let nc = B.imag let minus = B.minus let imag = B.imag let ints = B.ints let sum = B.sum let diff = B.diff let scale = B.scale let times = B.times let multiply = B.multiply let map = B.map let fuse = B.fuse let f_of_rep = B.f_of_rep let d_of_rep = B.d_of_rep module BinOps = B.BinOps let delta3 i j = [(LP.int 1, i ==> j)] let delta8 a b = [(LP.int 1, a <=> b)] (* If the~$\delta_{ab}$ originates from a~$\tr(T_aT_b)$, like an effective~$gg\to H\ldots$ coupling, it makes a difference in the color flow basis and we must write the full expression~(6.2) from~\cite{Kilian:2012pz} instead. *) let delta8_loop a b = [(LP.int 1, a <=> b); (LP.int 1, [a => a; ?? b]); (LP.int 1, [?? a; b => b]); (LP.nc 1, [?? a; ?? b])] (* The following can be used for computing polarization sums (eventually, this could make the [Flow] module redundant). Note that we have $-N_C$ instead of $-1/N_C$ in the ghost contribution here, because two factors of $-1/N_C$ will be produced by [add_arrow] below, when contracting two ghost indices. Indeed, with this definition we can maintain [multiply [delta8 1 (-1); gluon (-1) (-2); delta8 (-2) 2] = delta8 1 2]. *) let ghost a b = [ (LP.nc (-1), [?? a; ?? b])] let gluon a b = delta8 a b @ ghost a b (* \begin{dubious} Do we need to introduce an index \emph{pair} for each sextet index? Is that all? \end{dubious} *) let sextet n m = [ (LP.fraction 2, [(n, 0) >=>> (m, 0); (n, 1) >=>> (m, 1)]); (LP.fraction 2, [(n, 0) >=>> (m, 1); (n, 1) >=>> (m, 0)]) ] (* FIXME: note the flipped [i] and [j]! *) let t a j i = [ (LP.int 1, [i => a; a => j]); (LP.int 1, [i => j; ?? a]) ] (* Using the normalization~$\tr(T_{a}T_{b}) = \delta_{ab}$ we find with \begin{equation} \label{eq:f=tr(TTT)'} \ii f_{a_1a_2a_3} = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right) = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \end{equation} and \begin{multline} \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_3} T_{a_3}^{l_3l_1} T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = \\ \left( \delta^{l_1j_1} \delta^{i_1l_2} - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right) \left( \delta^{l_2j_2} \delta^{i_2l_3} - \frac{1}{N_C} \delta^{l_2l_3} \delta^{i_2j_2}\right) \left( \delta^{l_3j_3} \delta^{i_3l_1} - \frac{1}{N_C} \delta^{l_3l_1} \delta^{i_3j_3}\right) \end{multline} the decomposition \begin{equation} \label{eq:fTTT'} \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3} = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,. \end{equation} *) (* Indeed, \begin{verbatim} symbol nc; Dimension nc; vector i1, i2, i3, j1, j2, j3; index l1, l2, l3; local [TT] = ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j2(l2) * i2(l1) - d_(l2,l1) * i2.j2 / nc ); #procedure TTT(sign) local [TTT`sign'] = ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j2(l2) * i2(l3) - d_(l2,l3) * i2.j2 / nc ) * ( j3(l3) * i3(l1) - d_(l3,l1) * i3.j3 / nc ) `sign' ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc ) * ( j3(l2) * i3(l3) - d_(l2,l3) * i3.j3 / nc ) * ( j2(l3) * i2(l1) - d_(l3,l1) * i2.j2 / nc ); #endprocedure #call TTT(-) #call TTT(+) bracket nc; print; .sort .end \end{verbatim} gives \begin{verbatim} [TT] = + nc^-1 * ( - i1.j1*i2.j2 ) + i1.j2*i2.j1; [TTT-] = + i1.j2*i2.j3*i3.j1 - i1.j3*i2.j1*i3.j2; [TTT+] = + nc^-2 * ( 4*i1.j1*i2.j2*i3.j3 ) + nc^-1 * ( - 2*i1.j1*i2.j3*i3.j2 - 2*i1.j2*i2.j1*i3.j3 - 2*i1.j3*i2.j2*i3.j1 ) + i1.j2*i2.j3*i3.j1 + i1.j3*i2.j1*i3.j2; \end{verbatim} *) (* \begin{dubious} What about the overall sign? \end{dubious} *) let f a b c = [ (LP.imag ( 1), A.cycle [a; b; c]); (LP.imag (-1), A.cycle [a; c; b]) ] (* Except for the signs, the symmetric combination \emph{is} compatible with~(6.11) in our color flow paper~\cite{Kilian:2012pz}. There the signs are probably wrong, as they cancel in~(6.13). *) let d a b c = [ (LP.int 1, A.cycle [a; b; c]); (LP.int 1, A.cycle [a; c; b]); (LP.int 2, (a <=> b) @ [?? c]); (LP.int 2, (b <=> c) @ [?? a]); (LP.int 2, (c <=> a) @ [?? b]); (LP.int 2, [a => a; ?? b; ?? c]); (LP.int 2, [?? a; b => b; ?? c]); (LP.int 2, [?? a; ?? b; c => c]); (LP.nc 2, [?? a; ?? b; ?? c]) ] let incomplete tensor = failwith ("Color.Vertex: " ^ tensor ^ " not supported yet!") let experimental tensor = Printf.eprintf "Color.Vertex: %s support still experimental and untested!\n" tensor let epsilon i j k = incomplete "epsilon-tensor" let epsilonbar i j k = incomplete "epsilon-tensor" (* \begin{dubious} Is it enough to introduce an index \emph{pair} for each sextet index? \end{dubious} *) (* \begin{dubious} We need to find a way to make sure that we use particle/antiparticle assignments that a consistent with FeynRules. \end{dubious} *) let t6 a m n = experimental "t6-tensor"; [ (LP.int ( 1), [(n, 0) >=> a; a =>> (m, 0); (n, 1) >=>> (m, 1)]); (LP.int (-1), [(n, 0) >=>> (m, 0); (n, 1) >=>> (m, 1); ?? a]) ] (* \begin{dubious} How much symmetrization is required? \end{dubious} *) let t6_symmetrized a m n = experimental "t6-tensor"; [ (LP.int ( 1), [(n, 0) >=> a; a =>> (m, 0); (n, 1) >=>> (m, 1)]); (LP.int ( 1), [(n, 1) >=> a; a =>> (m, 0); (n, 0) >=>> (m, 1)]); (LP.int (-1), [(n, 0) >=>> (m, 0); (n, 1) >=>> (m, 1); ?? a]); (LP.int (-1), [(n, 1) >=>> (m, 0); (n, 0) >=>> (m, 1); ?? a]) ] let k6 m i j = experimental "k6-tensor"; [ (LP.int 1, [(m, 0) >=> i; (m, 1) >=> j]); (LP.int 1, [(m, 1) >=> i; (m, 0) >=> j]) ] let k6bar m i j = experimental "k6-tensor"; [ (LP.int 1, [i =>> (m, 0); j =>> (m, 1)]); (LP.int 1, [i =>> (m, 1); j =>> (m, 0)]) ] (* \thocwmodulesubsection{Unit Tests} *) module Test : Test = struct open OUnit module L = Algebra.Laurent module B = Birdtracks open Birdtracks open Birdtracks.BinOps let exorcise vertex = List.filter (fun (_, arrows) -> not (List.exists A.is_ghost arrows)) vertex let suite_sum = "sum" >::: [ "atoms" >:: (fun () -> assert_equal_vertices (two *** delta3 1 2) (delta3 1 2 +++ delta3 1 2)) ] let suite_diff = "diff" >::: [ "atoms" >:: (fun () -> assert_equal_vertices (delta3 3 4) (delta3 1 2 +++ delta3 3 4 --- delta3 1 2)) ] let suite_times = "times" >::: [ "t1*t2=t2*t1" >:: (fun () -> let t1 = t (-1) 1 (-2) and t2 = t (-1) (-2) 2 in assert_equal_vertices (t1 *** t2) (t2 *** t1)); "tr(t1*t2)=tr(t2*t1)" >:: (fun () -> let t1 = t 1 (-1) (-2) and t2 = t 2 (-2) (-1) in assert_equal_vertices (t1 *** t2) (t2 *** t1)); "reorderings" >:: (fun () -> let v1 = [(L.unit, [ 1 => -2; -2 => -1; -1 => 1])] and v2 = [(L.unit, [-1 => 2; 2 => -2; -2 => -1])] and v' = [(L.unit, [ 1 => 1; 2 => 2])] in assert_equal_vertices v' (v1 *** v2)) ] let suite_loops = "loops" >::: [ ] let suite_normalization = "normalization" >::: [ "tr(t*t)" >:: (fun () -> (* The use of [exorcise] appears to be legitimate here in the color flow representation, cf.~(6.2) of~\cite{Kilian:2012pz}. *) assert_equal_vertices (delta8 1 2) (exorcise (t 1 (-1) (-2) *** t 2 (-2) (-1)))); "d*d" >:: (fun () -> assert_equal_vertices [ (LP.ints [(2, 1); (-8,-1)], 1 <=> 2); (LP.ints [(2, 0); ( 4,-2)], [1=>1; 2=>2]) ] (exorcise (d 1 (-1) (-2) *** d 2 (-2) (-1)))) ] let commutator rep_t i_sum a b i j = multiply [rep_t a i i_sum; rep_t b i_sum j] --- multiply [rep_t b i i_sum; rep_t a i_sum j] let anti_commutator rep_t i_sum a b i j = multiply [rep_t a i i_sum; rep_t b i_sum j] +++ multiply [rep_t b i i_sum; rep_t a i_sum j] let trace3 rep_t a b c = rep_t a (-1) (-2) *** rep_t b (-2) (-3) *** rep_t c (-3) (-1) let trace3c rep_t a b c = third *** sum [trace3 rep_t a b c; trace3 rep_t b c a; trace3 rep_t c a b] let loop3 a b c = [ (LP.int 1, A.cycle (List.rev [a; b; c])); (LP.int 1, (a <=> b) @ [?? c]); (LP.int 1, (b <=> c) @ [?? a]); (LP.int 1, (c <=> a) @ [?? b]); (LP.int 1, [a => a; ?? b; ?? c]); (LP.int 1, [?? a; b => b; ?? c]); (LP.int 1, [?? a; ?? b; c => c]); (LP.nc 1, [?? a; ?? b; ?? c]) ] let suite_trace = "trace" >::: [ "tr(ttt)" >:: (fun () -> assert_equal_vertices (trace3 t 1 2 3) (loop3 1 2 3)); "tr(ttt) cyclic 1" >:: (fun () -> assert_equal_vertices (trace3 t 1 2 3) (trace3 t 2 3 1)); "tr(ttt) cyclic 2" >:: (fun () -> assert_equal_vertices (trace3 t 1 2 3) (trace3 t 3 1 2)) ] let suite_ghosts = "ghosts" >::: [ "H->gg" >:: (fun () -> assert_equal_vertices (delta8_loop 1 2) (t 1 (-1) (-2) *** t 2 (-2) (-1))); "H->ggg f" >:: (fun () -> assert_equal_vertices (imag *** f 1 2 3) (trace3c t 1 2 3 --- trace3c t 1 3 2)); "H->ggg d" >:: (fun () -> assert_equal_vertices (d 1 2 3) (trace3c t 1 2 3 +++ trace3c t 1 3 2)); "H->ggg f'" >:: (fun () -> assert_equal_vertices (imag *** f 1 2 3) (t 1 (-3) (-2) *** commutator t (-1) 2 3 (-2) (-3))); "H->ggg d'" >:: (fun () -> assert_equal_vertices (d 1 2 3) (t 1 (-3) (-2) *** anti_commutator t (-1) 2 3 (-2) (-3))); "H->ggg cyclic'" >:: (fun () -> let trace a b c = t a (-3) (-2) *** commutator t (-1) b c (-2) (-3) in assert_equal_vertices (trace 1 2 3) (trace 2 3 1)) ] (* FIXME: note the flipped [i], [j], [l], [k]! *) let tt j i l k = [ (LP.int 1, [i => l; k => j]); (LP.over_nc (-1), [i => j; k => l]) ] let ff a1 a2 a3 a4 = [ (LP.int (-1), A.cycle [a1; a2; a3; a4]); (LP.int ( 1), A.cycle [a2; a1; a3; a4]); (LP.int ( 1), A.cycle [a1; a2; a4; a3]); (LP.int (-1), A.cycle [a2; a1; a4; a3]) ] let tf j i a b = [ (LP.imag ( 1), A.chain [i; a; b; j]); (LP.imag (-1), A.chain [i; b; a; j]) ] let suite_ff = "f*f" >::: [ "1" >:: (fun () -> assert_equal_vertices (ff 1 2 3 4) (f (-1) 1 2 *** f (-1) 3 4)) ] let suite_tf = "t*f" >::: [ "1" >:: (fun () -> assert_equal_vertices (tf 1 2 3 4) (t (-1) 1 2 *** f (-1) 3 4)) ] let suite_tt = "t*t" >::: [ "1" >:: (fun () -> assert_equal_vertices (tt 1 2 3 4) (t (-1) 1 2 *** t (-1) 3 4)) ] let trace_comm rep_t a b c = rep_t a (-3) (-2) *** commutator rep_t (-1) b c (-2) (-3) (* FIXME: note the flipped [b], [c]! *) let t8 a c b = imag *** f a b c let suite_lie = "Lie algebra relations" >::: [ "[t,t]=ift" >:: (fun () -> assert_equal_vertices (imag *** f 1 2 (-1) *** t (-1) 3 4) (commutator t (-1) 1 2 3 4)); "if = tr(t[t,t])" >:: (fun () -> assert_equal_vertices (f 1 2 3) (f_of_rep t 1 2 3)); "[f,f]=-ff" >:: (fun () -> assert_equal_vertices (minus *** f 1 2 (-1) *** f (-1) 3 4) (commutator f (-1) 1 2 3 4)); "f = tr(f[f,f])" >:: (fun () -> assert_equal_vertices (two *** nc *** f 1 2 3) (trace_comm f 1 2 3)); "[t8,t8]=ift8" >:: (fun () -> assert_equal_vertices (imag *** f 1 2 (-1) *** t8 (-1) 3 4) (commutator t8 (-1) 1 2 3 4)); "inf = tr(t8[t8,t8])" >:: (fun () -> assert_equal_vertices (two *** nc *** f 1 2 3) (f_of_rep t8 1 2 3)); "[t6,t6]=ift6" >:: (fun () -> assert_equal_vertices (imag *** f 1 2 (-1) *** t6 (-1) 3 4) (commutator t6 (-1) 1 2 3 4)); "inf = tr(t6[t6,t6])" >:: (fun () -> assert_equal_vertices (nc *** f 1 2 3) (f_of_rep t6 1 2 3)) ] let prod3 rep_t a b c i j = rep_t a i (-1) *** rep_t b (-1) (-2) *** rep_t c (-2) j let jacobi1 rep_t a b c i j = (prod3 rep_t a b c i j --- prod3 rep_t a c b i j) --- (prod3 rep_t b c a i j --- prod3 rep_t c b a i j) let jacobi rep_t = sum [jacobi1 rep_t 1 2 3 4 5; jacobi1 rep_t 2 3 1 4 5; jacobi1 rep_t 3 1 2 4 5] let suite_jacobi = "Jacobi identities" >::: [ "fund." >:: (fun () -> assert_equal_vertices null (jacobi t)); "adj." >:: (fun () -> assert_equal_vertices null (jacobi f)); "S2" >:: (fun () -> assert_equal_vertices null (jacobi t6)) ] (* From \texttt{hep-ph/0611341} for $\mathrm{SU}(N)$ for the adjoint, symmetric and antisymmetric representations \begin{subequations} \begin{align} C_2(\text{adj}) &= 2N \\ C_2(S_n) &= \frac{n(N-1)(N+n)}{N} \\ C_2(A_n) &= \frac{n(N-n)(N+1)}{N} \end{align} \end{subequations} adjusted for our normalization. In particular \begin{subequations} \begin{align} C_2(\text{fund.}) = C_2(S_1) &= \frac{N^2-1}{N} \\ C_2(S_2) &= \frac{2(N-1)(N+2)}{N} = 2 \frac{N^2+N-2}{N} \end{align} \end{subequations} *) (* $N_C-1/N_C=(N_C^2-1)/N_C$ *) let cf = LP.ints [(1, 1); (-1, -1)] (* $N_C^2-5+4/N_C^2=(N_C^2-1)(N_C^2-4)/N_C^2$ *) let c3f = LP.ints [(1, 2); (-5, 0); (4, -2)] (* $2N_C$ *) let ca = LP.ints [(2, 1)] (* $2N_C+2N_C-4/N_C=2(N_C-1)(N_C+2)/N_C$ *) let c6 = LP.ints [(2, 1); (2, 0); (-4, -1)] let casimir_tt i j = [(cf, i ==> j)] let casimir_ttt i j = [(c3f, i ==> j)] let casimir_ff a b = [(ca, 1 <=> 2); (LP.int (-2), [1=>1; 2=>2])] (* FIXME: normalization and/or symmetrization? *) let casimir_t6t6 i j = [(cf, [(i,0) >=>> (j,0); (i,1) >=>> (j,1)])] let casimir_t6t6_symmetrized i j = half *** [ (c6, [(i,0) >=>> (j,0); (i,1) >=>> (j,1)]); (c6, [(i,0) >=>> (j,1); (i,1) >=>> (j,0)]) ] let suite_casimir = "Casimir operators" >::: [ "t*t" >:: (* Again, we appear to have the complex conjugate (transposed) representation\ldots *) (fun () -> assert_equal_vertices (casimir_tt 2 1) (t (-1) (-2) 2 *** t (-1) 1 (-2))); "t*t*t" >:: (fun () -> assert_equal_vertices (casimir_ttt 2 1) (d (-1) (-2) (-3) *** t (-1) 1 (-4) *** t (-2) (-4) (-5) *** t (-3) (-5) 2)); "f*f" >:: (fun () -> assert_equal_vertices (casimir_ff 1 2) (minus *** f (-1) 1 (-2) *** f (-1) (-2) 2)); "t6*t6" >:: (fun () -> assert_equal_vertices (casimir_t6t6 2 1) (t6 (-1) (-2) 2 *** t6 (-1) 1 (-2))) ] let suite_colorsums = "(squared) color sums" >::: [ "gluon normalization" >:: (fun () -> assert_equal_vertices (delta8 1 2) (delta8 1 (-1) *** gluon (-1) (-2) *** delta8 (-2) 2)); "f*f" >:: (fun () -> let sum_ff = multiply [ f (-11) (-12) (-13); f (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] and expected = ints [(2, 3); (-2, 1)] in assert_equal_vertices expected sum_ff); "d*d" >:: (fun () -> let sum_dd = multiply [ d (-11) (-12) (-13); d (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] and expected = ints [(2, 3); (-10, 1); (8, -1)] in assert_equal_vertices expected sum_dd); "f*d" >:: (fun () -> let sum_fd = multiply [ f (-11) (-12) (-13); d (-21) (-22) (-23); gluon (-11) (-21); gluon (-12) (-22); gluon (-13) (-23) ] in assert_equal_vertices null sum_fd); "Hgg" >:: (fun () -> let sum_hgg = multiply [ delta8_loop (-11) (-12); delta8_loop (-21) (-22); gluon (-11) (-21); gluon (-12) (-22) ] and expected = ints [(1, 2); (-1, 0)] in assert_equal_vertices expected sum_hgg) ] let suite = "Color.SU3" >::: [suite_sum; suite_diff; suite_times; suite_normalization; suite_ghosts; suite_loops; suite_trace; suite_ff; suite_tf; suite_tt; suite_lie; suite_jacobi; suite_casimir; suite_colorsums] end end module U3 : SU3 = struct module A = Arrow open Arrow.BinOps module B = Birdtracks type t = B.t let to_string = B.to_string let pp = B.pp let trivial = B.trivial let is_null = B.is_null let null = B.null let unit = B.unit let const = B.const let two = B.two let half = B.half let third = B.third let nc = B.imag let minus = B.minus let imag = B.imag let ints = B.ints let sum = B.sum let diff = B.diff let scale = B.scale let times = B.times let multiply = B.multiply let map = B.map let fuse = B.fuse let f_of_rep = B.f_of_rep let d_of_rep = B.d_of_rep module BinOps = B.BinOps let delta3 i j = [(LP.int 1, i ==> j)] let delta8 a b = [(LP.int 1, a <=> b)] let delta8_loop = delta8 let gluon a b = delta8 a b (* \begin{dubious} Do we need to introduce an index \emph{pair} for each sextet index? Is that all? \end{dubious} *) let sextet n m = [ (LP.fraction 2, [(n, 0) >=>> (m, 0); (n, 1) >=>> (m, 1)]); (LP.fraction 2, [(n, 0) >=>> (m, 1); (n, 1) >=>> (m, 0)]) ] let t a j i = [ (LP.int 1, [i => a; a => j]) ] let f a b c = [ (LP.imag ( 1), A.cycle [a; b; c]); (LP.imag (-1), A.cycle [a; c; b]) ] let d a b c = [ (LP.int 1, A.cycle [a; b; c]); (LP.int 1, A.cycle [a; c; b]) ] let incomplete tensor = failwith ("Color.Vertex: " ^ tensor ^ " not supported yet!") let experimental tensor = Printf.eprintf "Color.Vertex: %s support still experimental and untested!\n" tensor let epsilon i j k = incomplete "epsilon-tensor" let epsilonbar i j k = incomplete "epsilon-tensor" let t6 a m n = experimental "t6-tensor"; [ (LP.int ( 1), [(n, 0) >=> a; a =>> (m, 0); (n, 1) >=>> (m, 1)]) ] (* \begin{dubious} How much symmetrization is required? \end{dubious} *) let t6_symmetrized a m n = experimental "t6-tensor"; [ (LP.int ( 1), [(n, 0) >=> a; a =>> (m, 0); (n, 1) >=>> (m, 1)]); (LP.int ( 1), [(n, 1) >=> a; a =>> (m, 0); (n, 0) >=>> (m, 1)]) ] let k6 m i j = experimental "k6-tensor"; [ (LP.int 1, [(m, 0) >=> i; (m, 1) >=> j]); (LP.int 1, [(m, 1) >=> i; (m, 0) >=> j]) ] let k6bar m i j = experimental "k6-tensor"; [ (LP.int 1, [i =>> (m, 0); j =>> (m, 1)]); (LP.int 1, [i =>> (m, 1); j =>> (m, 0)]) ] (* \thocwmodulesubsection{Unit Tests} *) module Test : Test = struct open OUnit open Birdtracks open BinOps let suite_lie = "Lie algebra relations" >::: [ "if = tr(t[t,t])" >:: (fun () -> assert_equal_vertices (f 1 2 3) (f_of_rep t 1 2 3)) ] (* $N_C=N_C^2/N_C$ *) let cf = LP.ints [(1, 1)] let casimir_tt i j = [(cf, i ==> j)] let suite_casimir = "Casimir operators" >::: [ "t*t" >:: (fun () -> assert_equal_vertices (casimir_tt 2 1) (t (-1) (-2) 2 *** t (-1) 1 (-2))) ] let suite = "Color.U3" >::: [suite_lie; suite_casimir] end end module Vertex = SU3 Index: trunk/omega/src/thoString.mli =================================================================== --- trunk/omega/src/thoString.mli (revision 8305) +++ trunk/omega/src/thoString.mli (revision 8306) @@ -1,60 +1,60 @@ (* thoString.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* This is a very simple library if stroing manipulation functions missing in O'Caml's standard library. *) (* [strip_prefix prefix string] returns [string] with 0 or 1 occurences of a leading [prefix] removed. *) val strip_prefix : string -> string -> string (* [strip_prefix_star prefix string] returns [string] with any number of leading occurences of [prefix] removed. *) val strip_prefix_star : char -> string -> string (* [strip_prefix prefix string] returns [string] with a leading [prefix] removed, raises [Invalid_argument] if there's no match. *) val strip_required_prefix : string -> string -> string (* [strip_from_first c s] returns [s] with everything starting from the first [c] removed. [strip_from_last c s] returns [s] with everything starting from the last [c] removed. *) val strip_from_first : char -> string -> string val strip_from_last : char -> string -> string (* [index_string pattern string] returns the index of the first occurence of [pattern] in [string], if any. Raises [Not_found], if [pattern] is not in [string]. *) val index_string : string -> string -> int (* This silently fails if the argument contains both single and double quotes! *) val quote : string -> string -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) +(* The corresponding functions from [String] have become obsolescent + with O'Caml~4.0.3. Quanrantine them here. *) +val uppercase : string -> string +val lowercase : string -> string + +(* Ignore the case in comparisons. *) +val compare_caseless : string -> string -> int Index: trunk/omega/src/vertex.ml =================================================================== --- trunk/omega/src/vertex.ml (revision 8305) +++ trunk/omega/src/vertex.ml (revision 8306) @@ -1,1695 +1,1699 @@ (* vertex.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + module type Test = sig val example : unit -> unit val suite : OUnit.test end (* \thocwmodulesection{New Implementation: Next Version} *) let error_in_string text start_pos end_pos = let i = start_pos.Lexing.pos_cnum and j = end_pos.Lexing.pos_cnum in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) let parse_string text = Vertex_syntax.File.expand_includes (fun file -> invalid_arg ("parse_string: found include `" ^ file ^ "'")) (try Vertex_parser.file Vertex_lexer.token (Vertex_lexer.init_position "" (Lexing.from_string text)) with | Vertex_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text)) let parse_file name = let parse_file_tree name = let ic = open_in name in let file_tree = begin try Vertex_parser.file Vertex_lexer.token (Vertex_lexer.init_position name (Lexing.from_channel ic)) with | Vertex_syntax.Syntax_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: syntax error (%s)" (error_in_file name start_pos end_pos) msg) end | Parsing.Parse_error -> begin close_in ic; invalid_arg ("parse error: " ^ name) end end in close_in ic; file_tree in Vertex_syntax.File.expand_includes parse_file_tree (parse_file_tree name) let dump_file pfx f = List.iter (fun s -> print_endline (pfx ^ ": " ^ s)) (Vertex_syntax.File.to_strings f) module Parser_Test : Test = struct let example () = () open OUnit let compare s_out s_in () = assert_equal ~printer:(String.concat " ") [s_out] (Vertex_syntax.File.to_strings (parse_string s_in)) let parse_error error s () = assert_raises (Invalid_argument error) (fun () -> parse_string s) let syntax_error (msg, error) s () = parse_error ("syntax error (" ^ msg ^ ") at: `" ^ error ^ "'") s () let (=>) s_in s_out = " " ^ s_in >:: compare s_out s_in let (?>) s = s => s let (=>!!!) s error = " " ^ s >:: parse_error error s let (=>!) s error = " " ^ s >:: syntax_error error s let empty = "empty" >:: (fun () -> assert_equal [] (parse_string "")) let expr = "expr" >::: [ "\\vertex[2 * (17 + 4)]{}" => "\\vertex[42]{{}}"; "\\vertex[2 * 17 + 4]{}" => "\\vertex[38]{{}}"; "\\vertex[2" =>! ("missing `]'", "[2"); "\\vertex]{}" =>! ("expected `[' or `{'", "\\vertex]"); "\\vertex2]{}" =>! ("expected `[' or `{'", "\\vertex2"); "\\vertex}{}" =>! ("expected `[' or `{'", "\\vertex}"); "\\vertex2}{}" =>! ("expected `[' or `{'", "\\vertex2"); "\\vertex[(2}{}" =>! ("expected `)', found `}'", "(2}"); "\\vertex[(2]{}" =>! ("expected `)', found `]'", "(2]"); "\\vertex{2]{}" =>! ("syntax error", "2"); "\\vertex[2}{}" =>! ("expected `]', found `}'", "[2}"); "\\vertex[2{}" =>! ("syntax error", "2"); "\\vertex[2*]{}" =>! ("syntax error", "2") ] let index = "index" >::: [ "\\vertex{{a}_{1}^{2}}" => "\\vertex{a^2_1}"; "\\vertex{a_{11}^2}" => "\\vertex{a^2_{11}}"; "\\vertex{a_{1_1}^2}" => "\\vertex{a^2_{1_1}}" ] let electron1 = "electron1" >::: [ ?> "\\charged{e^-}{e^+}"; "\\charged{{e^-}}{{e^+}}" => "\\charged{e^-}{e^+}" ] let electron2 = "electron2" >::: [ "\\charged{e^-}{e^+}\\fortran{ele}" => "\\charged{e^-}{e^+}\\fortran{{ele}}"; "\\charged{e^-}{e^+}\\fortran{electron}\\fortran{ele}" => "\\charged{e^-}{e^+}\\fortran{{ele}}\\fortran{{electron}}"; "\\charged{e^-}{e^+}\\alias{e2}\\alias{e1}" => "\\charged{e^-}{e^+}\\alias{{e1}}\\alias{{e2}}"; "\\charged{e^-}{e^+}\\fortran{ele}\\anti\\fortran{pos}" => "\\charged{e^-}{e^+}\\fortran{{ele}}\\anti\\fortran{{pos}}" ] let particles = "particles" >::: [electron1; electron2] let parameters = "parameters" >::: [ ?> "\\parameter{\\alpha}{1/137}"; ?> "\\derived{\\alpha_s}{1/\\ln{\\frac{\\mu}{\\Lambda}}}"; "\\parameter{\\alpha}{1/137}\\anti\\fortran{alpha}" =>! ("invalid parameter attribute", "\\anti") ] let indices = "indices" >::: [ ?> "\\index{a}\\color{8}"; "\\index{a}\\color[SU(2)]{3}" => "\\index{a}\\color[{SU(2)}]{3}" ] let tensors = "tensors" >::: [ "\\tensor{T}\\color{3}" => "\\tensor{T}\\color{3}"] let vertices = "vertex" >::: [ "\\vertex{\\bar\\psi\\gamma_\\mu\\psi A_\\mu}" => "\\vertex{{{\\bar\\psi\\gamma_\\mu\\psi A_\\mu}}}" ] module T = Vertex_syntax.Token let parse_token s = match parse_string ("\\vertex{" ^ s ^ "}") with | [Vertex_syntax.File.Vertex (_, v)] -> v | _ -> invalid_arg "only_vertex" let print_token pfx t = print_endline (pfx ^ ": " ^ T.to_string t) let test_stem s_out s_in () = assert_equal ~printer:T.to_string (parse_token s_out) (T.stem (parse_token s_in)) let (=>>) s_in s_out = "stem " ^ s_in >:: test_stem s_out s_in let tokens = "tokens" >::: [ "\\vertex{a'}" => "\\vertex{a^\\prime}"; "\\vertex{a''}" => "\\vertex{a^{\\prime\\prime}}"; "\\bar\\psi''_{i,\\alpha}" =>> "\\psi"; "\\phi^\\dagger_{i'}" =>> "\\phi"; "\\bar{\\phi\\psi}''_{i,\\alpha}" =>> "\\psi"; "\\vertex{\\phi}" => "\\vertex{\\phi}"; "\\vertex{\\phi_1}" => "\\vertex{\\phi_1}"; "\\vertex{{{\\phi}'}}" => "\\vertex{\\phi^\\prime}"; "\\vertex{\\hat{\\bar\\psi}_1}" => "\\vertex{\\hat\\bar\\psi_1}"; "\\vertex{{a_b}_{cd}}" => "\\vertex{a_{bcd}}"; "\\vertex{{\\phi_1}_2}" => "\\vertex{\\phi_{12}}"; "\\vertex{{\\phi_{12}}_{34}}" => "\\vertex{\\phi_{1234}}"; "\\vertex{{\\phi_{12}}^{34}}" => "\\vertex{\\phi^{34}_{12}}"; "\\vertex{\\bar{\\psi_{\\mathrm{e}}}_\\alpha\\gamma_{\\alpha\\beta}^\\mu{\\psi_{\\mathrm{e}}}_\\beta}" => "\\vertex{{{\\bar\\psi_{\\mathrm e\\alpha}\\gamma^\\mu_{\\alpha\\beta}\\psi_{\\mathrm e\\beta}}}}"] let suite = "Vertex_Parser" >::: [empty; index; expr; particles; parameters; indices; tensors; vertices; tokens ] end (* \thocwmodulesubsection{Symbol Tables} *) module type Symbol = sig type file = Vertex_syntax.File.t type t = Vertex_syntax.Token.t (* Tensors and their indices are representations of color, flavor or Lorentz groups. In the end it might turn out to be unnecessary to distinguish [Color] from [Flavor]. *) type space = | Color of Vertex_syntax.Lie.t | Flavor of t list * t list | Lorentz of t list (* A symbol (i.\,e.~a [Symbol.t = Vertex_syntax.Token.t]) can refer either to particles, to parameters (derived and input) or to tensors and indices. *) type kind = | Neutral | Charged | Anti | Parameter | Derived | Index of space | Tensor of space type table val load : file -> table val dump : out_channel -> table -> unit (* Look up the [kind] of a symbol. *) val kind_of_symbol : table -> t -> kind option (* Look up the [kind] of a symbol's stem. *) val kind_of_stem : table -> t -> kind option (* Look up the [kind] of a symbol and fall back to the [kind] of the symbol's stem, if necessary. *) val kind_of_symbol_or_stem : table -> t -> kind option (* A table to look up all symbols with the same [stem]. *) val common_stem : table -> t -> t list exception Missing_Space of t exception Conflicting_Space of t end module Symbol : Symbol = struct module T = Vertex_syntax.Token module F = Vertex_syntax.File module P = Vertex_syntax.Particle module I = Vertex_syntax.Index module L = Vertex_syntax.Lie module Q = Vertex_syntax.Parameter module X = Vertex_syntax.Tensor type file = F.t type t = T.t type space = | Color of L.t | Flavor of t list * t list | Lorentz of t list let space_to_string = function | Color (g, r) -> "color:" ^ L.group_to_string g ^ ":" ^ L.rep_to_string r | Flavor (_, _) -> "flavor" | Lorentz _ -> "Lorentz" type kind = | Neutral | Charged | Anti | Parameter | Derived | Index of space | Tensor of space let kind_to_string = function | Neutral -> "neutral particle" | Charged -> "charged particle" | Anti -> "charged anti particle" | Parameter -> "input parameter" | Derived -> "derived parameter" | Index space -> space_to_string space ^ " index" | Tensor space -> space_to_string space ^ " tensor" module ST = Map.Make (T) module SS = Set.Make (T) type table = { symbol_kinds : kind ST.t; stem_kinds : kind ST.t; common_stems : SS.t ST.t } let empty = { symbol_kinds = ST.empty; stem_kinds = ST.empty; common_stems = ST.empty } let kind_of_symbol table token = try Some (ST.find token table.symbol_kinds) with Not_found -> None let kind_of_stem table token = try Some (ST.find (T.stem token) table.stem_kinds) with | Not_found -> None let kind_of_symbol_or_stem symbol_table token = match kind_of_symbol symbol_table token with | Some _ as kind -> kind | None -> kind_of_stem symbol_table token let common_stem table token = try SS.elements (ST.find (T.stem token) table.common_stems) with | Not_found -> [] let add_symbol_kind table token kind = try let old_kind = ST.find token table in if kind = old_kind then table else invalid_arg ("conflicting symbol kind: " ^ T.to_string token ^ " -> " ^ kind_to_string kind ^ " vs " ^ kind_to_string old_kind) with | Not_found -> ST.add token kind table let add_stem_kind table token kind = let stem = T.stem token in try let old_kind = ST.find stem table in if kind = old_kind then table else begin match kind, old_kind with | Charged, Anti -> ST.add stem Charged table | Anti, Charged -> table | _, _ -> invalid_arg ("conflicting stem kind: " ^ T.to_string token ^ " -> " ^ T.to_string stem ^ " -> " ^ kind_to_string kind ^ " vs " ^ kind_to_string old_kind) end with | Not_found -> ST.add stem kind table let add_kind table token kind = { table with symbol_kinds = add_symbol_kind table.symbol_kinds token kind; stem_kinds = add_stem_kind table.stem_kinds token kind } let add_stem table token = let stem = T.stem token in let set = try ST.find stem table.common_stems with | Not_found -> SS.empty in { table with common_stems = ST.add stem (SS.add token set) table.common_stems } (* Go through the list of attributes, make sure that the [space] is declared and unique. Return the space. *) exception Missing_Space of t exception Conflicting_Space of t let group_rep_of_tokens group rep = let group = match group with | [] -> L.default_group | group -> L.group_of_string (T.list_to_string group) in Color (group, L.rep_of_string group (T.list_to_string rep)) let index_space index = let spaces = List.fold_left (fun acc -> function | I.Color (group, rep) -> group_rep_of_tokens group rep :: acc | I.Flavor (group, rep) -> Flavor (rep, group) :: acc | I.Lorentz t -> Lorentz t :: acc) [] index.I.attr in match ThoList.uniq (List.sort compare spaces) with | [space] -> space | [] -> raise (Missing_Space index.I.name) | _ -> raise (Conflicting_Space index.I.name) let tensor_space tensor = let spaces = List.fold_left (fun acc -> function | X.Color (group, rep) -> group_rep_of_tokens rep group :: acc | X.Flavor (group, rep) -> Flavor (rep, group) :: acc | X.Lorentz t -> Lorentz t :: acc) [] tensor.X.attr in match ThoList.uniq (List.sort compare spaces) with | [space] -> space | [] -> raise (Missing_Space tensor.X.name) | _ -> raise (Conflicting_Space tensor.X.name) (* NB: if [P.Charged (name, name)] below, only the [Charged] will survive, [Anti] will be shadowed. *) let insert_kind table = function | F.Particle p -> begin match p.P.name with | P.Neutral name -> add_kind table name Neutral | P.Charged (name, anti) -> add_kind (add_kind table anti Anti) name Charged end | F.Index i -> add_kind table i.I.name (Index (index_space i)) | F.Tensor t -> add_kind table t.X.name (Tensor (tensor_space t)) | F.Parameter p -> begin match p with | Q.Parameter name -> add_kind table name.Q.name Parameter | Q.Derived name -> add_kind table name.Q.name Derived end | F.Vertex _ -> table let insert_stem table = function | F.Particle p -> begin match p.P.name with | P.Neutral name -> add_stem table name | P.Charged (name, anti) -> add_stem (add_stem table name) anti end | F.Index i -> add_stem table i.I.name | F.Tensor t -> add_stem table t.X.name | F.Parameter p -> begin match p with | Q.Parameter name | Q.Derived name -> add_stem table name.Q.name end | F.Vertex _ -> table let insert table token = insert_stem (insert_kind table token) token let load decls = List.fold_left insert empty decls let dump oc table = Printf.fprintf oc "<<< Symbol Table: >>>\n"; ST.iter (fun s k -> Printf.fprintf oc "%s -> %s\n" (T.to_string s) (kind_to_string k)) table.symbol_kinds; Printf.fprintf oc "<<< Stem Table: >>>\n"; ST.iter (fun s k -> Printf.fprintf oc "%s -> %s\n" (T.to_string s) (kind_to_string k)) table.stem_kinds; Printf.fprintf oc "<<< Common Stems: >>>\n"; ST.iter (fun stem symbols -> Printf.fprintf oc "%s -> %s\n" (T.to_string stem) (String.concat ", " (List.map T.to_string (SS.elements symbols)))) table.common_stems end (* \thocwmodulesubsection{Declarations} *) module type Declaration = sig type t val of_string : string -> t list val to_string : t list -> string (* For testing and debugging *) val of_string_and_back : string -> string val count_indices : t -> (int * Symbol.t) list val indices_ok : t -> unit end module Declaration : Declaration = struct module S = Symbol module T = Vertex_syntax.Token type factor = { stem : T.t; prefix : T.prefix list; particle : T.t list; color : T.t list; flavor : T.t list; lorentz : T.t list; other : T.t list } type t = factor list let factor_stem token = { stem = token.T.stem; prefix = token.T.prefix; particle = []; color = []; flavor = []; lorentz = []; other = [] } let rev factor = { stem = factor.stem; prefix = List.rev factor.prefix; particle = List.rev factor.particle; color = List.rev factor.color; flavor = List.rev factor.flavor; lorentz = List.rev factor.lorentz; other = List.rev factor.other } let factor_add_prefix factor token = { factor with prefix = T.prefix_of_string token :: factor.prefix } let factor_add_particle factor token = { factor with particle = token :: factor.particle } let factor_add_color_index t factor token = { factor with color = token :: factor.color } let factor_add_lorentz_index t factor token = (* diagnostics: [Printf.eprintf "[L:[%s]]\n" (T.to_string token);] *) { factor with lorentz = token :: factor.lorentz } let factor_add_flavor_index t factor token = { factor with flavor = token :: factor.flavor } let factor_add_other_index factor token = { factor with other = token :: factor.other } let factor_add_kind factor token = function | S.Neutral | S.Charged | S.Anti -> factor_add_particle factor token | S.Index (S.Color (rep, group)) -> factor_add_color_index (rep, group) factor token | S.Index (S.Flavor (rep, group)) -> factor_add_flavor_index (rep, group) factor token | S.Index (S.Lorentz t) -> factor_add_lorentz_index t factor token | S.Tensor _ -> invalid_arg "factor_add_index: \\tensor" | S.Parameter -> invalid_arg "factor_add_index: \\parameter" | S.Derived -> invalid_arg "factor_add_index: \\derived" let factor_add_index symbol_table factor = function | T.Token "," -> factor | T.Token ("*" | "\\ast" as star) -> factor_add_prefix factor star | token -> begin match S.kind_of_symbol_or_stem symbol_table token with | Some kind -> factor_add_kind factor token kind | None -> factor_add_other_index factor token end let factor_of_token symbol_table token = let token = T.wrap_scripted token in rev (List.fold_left (factor_add_index symbol_table) (factor_stem token) (token.T.super @ token.T.sub)) let list_to_string tag = function | [] -> "" | l -> "; " ^ tag ^ "=" ^ String.concat "," (List.map T.to_string l) let factor_to_string factor = "[" ^ T.to_string factor.stem ^ (match factor.prefix with | [] -> "" | l -> "; prefix=" ^ String.concat "," (List.map T.prefix_to_string l)) ^ list_to_string "particle" factor.particle ^ list_to_string "color" factor.color ^ list_to_string "flavor" factor.flavor ^ list_to_string "lorentz" factor.lorentz ^ list_to_string "other" factor.other ^ "]" let count_indices factors = ThoList.classify (ThoList.flatmap (fun f -> f.color @ f.flavor @ f.lorentz) factors) let format_mismatch (n, index) = Printf.sprintf "index %s appears %d times" (T.to_string index) n let indices_ok factors = match List.filter (fun (n, _) -> n <> 2) (count_indices factors) with | [] -> () | mismatches -> invalid_arg (String.concat ", " (List.map format_mismatch mismatches)) let of_string s = let decls = parse_string s in let symbol_table = Symbol.load decls in (* diagnostics: [Symbol.dump stderr symbol_table;] *) let tokens = List.fold_left (fun acc -> function | Vertex_syntax.File.Vertex (_, v) -> T.wrap_list v :: acc | _ -> acc) [] decls in let vlist = List.map (List.map (factor_of_token symbol_table)) tokens in List.iter indices_ok vlist; vlist let to_string decls = String.concat "; " (List.map (fun v -> String.concat " * " (List.map factor_to_string v)) decls) let of_string_and_back s = to_string (of_string s) type field = { name : T.t list } end (* \thocwmodulesubsection{Complete Models} *) module Modelfile = struct end module Modelfile_Test = struct let example () = () open OUnit let index_mismatches = "index mismatches" >::: [ "1" >:: (fun () -> assert_raises (Invalid_argument "index a_1 appears 1 times, \ index a_2 appears 1 times") (fun () -> Declaration.of_string_and_back "\\index{a}\\color{3}\ \\vertex{\\bar\\psi_{a_1}\\psi_{a_2}}")); "3" >:: (fun () -> assert_raises (Invalid_argument "index a appears 3 times") (fun () -> Declaration.of_string_and_back "\\index{a}\\color{3}\ \\vertex{\\bar\\psi_a\\psi_a\\phi_a}")) ] let kind_conflicts = "kind conflictings" >::: [ "lorentz / color" >:: (fun () -> assert_raises (Invalid_argument "conflicting stem kind: a_2 -> a -> \ Lorentz index vs color:SU(3):3 index") (fun () -> Declaration.of_string_and_back "\\index{a_1}\\color{3}\ \\index{a_2}\\lorentz{X}")); "color / color" >:: (fun () -> assert_raises (Invalid_argument "conflicting stem kind: a_2 -> a -> \ color:SU(3):8 index vs color:SU(3):3 index") (fun () -> Declaration.of_string_and_back "\\index{a_1}\\color{3}\ \\index{a_2}\\color{8}")); "neutral / charged" >:: (fun () -> assert_raises (Invalid_argument "conflicting stem kind: H^- -> H -> \ charged anti particle vs neutral particle") (fun () -> Declaration.of_string_and_back "\\neutral{H}\ \\charged{H^+}{H^-}")) ] let suite = "Modelfile_Test" >::: [ "ok" >:: (fun () -> assert_equal ~printer:(fun s -> s) "[\\psi; prefix=\\bar; \ particle=e; color=a; lorentz=\\alpha_1] * \ [\\gamma; lorentz=\\mu,\\alpha_1,\\alpha_2] * \ [\\psi; particle=e; color=a; lorentz=\\alpha_2] * \ [A; lorentz=\\mu]" (Declaration.of_string_and_back "\\charged{e^-}{e^+}\ \\index{a}\\color{\\bar3}\ \\index{b}\\color[SU(3)]{8}\ \\index{\\mu}\\lorentz{X}\ \\index{\\alpha}\\lorentz{X}\ \\vertex{\\bar{\\psi_e}_{a,\\alpha_1}\ \\gamma^\\mu_{\\alpha_1\\alpha_2}\ {\\psi_e}_{a,\\alpha_2}A_\\mu}")); index_mismatches; kind_conflicts; "QCD.omf" >:: (fun () -> dump_file "QCD" (parse_file "QCD.omf")); "SM.omf" >:: (fun () -> dump_file "SM" (parse_file "SM.omf")); "SM-error.omf" >:: (fun () -> assert_raises (Invalid_argument "SM-error.omf:32.22-32.27: syntax error (syntax error)") (fun () -> parse_file "SM-error.omf")); "cyclic.omf" >:: (fun () -> assert_raises (Invalid_argument "cyclic \\include{cyclic.omf}") (fun () -> parse_file "cyclic.omf")) ] end (* \thocwmodulesection{New Implementation: Obsolete Version~1} *) (* Start of version 1 of the new implementation. The old syntax will not be used in the real implementation, but the library for dealing with indices and permutations will remail important. *) (* Note that [arity = length lorentz_reps = length color_reps]. Do we need to enforce this by an abstract type constructor? A cleaner approach would be [type context = (Coupling.lorentz, Color.t) array], but it would also require more tedious deconstruction of the pairs. Well, an abstract type with accessors might be the way to go after all \ldots *) type context = { arity : int; lorentz_reps : Coupling.lorentz array; color_reps : Color.t array } let distinct2 i j = i <> j let distinct3 i j k = i <> j && j <> k && k <> i let distinct ilist = List.length (ThoList.uniq (List.sort compare ilist)) = List.length ilist (* An abstract type that allows us to distinguish offsets in the field array from color and Lorentz indices in different representations. *) module type Index = sig type t val of_int : int -> t val to_int : t -> int end (* While the number of allowed indices is unlimited, the allowed offsets into the field arrays are of course restricted to the fields in the current [context]. *) module type Field = sig type t exception Out_of_range of int val of_int : context -> int -> t val to_int : t -> int val get : 'a array -> t -> 'a end module Field : Field = struct type t = int exception Out_of_range of int let of_int context i = if 0 <= i && i < context.arity then i else raise (Out_of_range i) let to_int i = 0 let get = Array.get end type field = Field.t module type Lorentz = sig (* We combine indices~[I] and offsets~[F] into the field array into a single type so that we can unify vectors with vector components. *) type index = I of int | F of field type vector = Vector of index type spinor = Spinor of index type conjspinor = ConjSpinor of index (* These are all the primitive ways to construct Lorentz tensors, a.\,k.\,a.~objects with Lorentz indices, from momenta, other Lorentz tensors and Dirac spinors: *) type primitive = | G of vector * vector (* $g_{\mu_1\mu_2}$ *) | E of vector * vector * vector * vector (* $\epsilon_{\mu_1\mu_2\mu_3\mu_4}$ *) | K of vector * field (* $k_{2}^{\mu_1}$ *) | S of conjspinor * spinor (* $\bar\psi_1\psi_2$ *) | V of vector * conjspinor * spinor (* $\bar\psi_1\gamma_{\mu_2}\psi_3$ *) | T of vector * vector * conjspinor * spinor (* $\bar\psi_1\sigma_{\mu_2\mu_3}\psi_4$ *) | A of vector * conjspinor * spinor (* $\bar\psi_1\gamma_{\mu_2}\gamma_5\psi_3$ *) | P of conjspinor * spinor (* $\bar\psi_1\gamma_5\psi_2$ *) type tensor = int * primitive list (* Below, we will need to permute fields. For this purpose, we introduce the function [map_primitive v_idx v_fld s_idx s_fld c_idx c_fld tensor] that returns a structurally identical tensor, with [v_idx : int -> int] applied to all vector indices, [v_fld : field -> field] to all vector fields, [s_idx] and [c_idx] to all (conj)spinor indices and [s_fld] and [c_fld] to all (conj)spinor fields. Note we must treat spinors and vectors differently, even for simple permuations, in order to handle the statistics properly. *) val map_tensor : (int -> int) -> (field -> field) -> (int -> int) -> (field -> field) -> (int -> int) -> (field -> field) -> tensor -> tensor (* Check whether the [tensor] is well formed in the [context]. *) val tensor_ok : context -> tensor -> bool (* The lattice $\mathbf{N}+\mathrm{i}\mathbf{N}\subset\mathbf{C}$, which suffices for representing the matrix elements of Dirac matrices. We hope to be able to avoid the lattice $\mathbf{Q}+\mathrm{i}\mathbf{Q}\subset\mathbf{C}$ or $\mathbf{C}$ itself down the road. *) module Complex : sig type t = int * int type t' = | Z (* $0$ *) | O (* $1$ *) | M (* $-1$ *) | I (* $\mathrm{i}$ *) | J (* $-\mathrm{i}$ *) | C of int * int (* $x+\mathrm{i}y$ *) val to_fortran : t' -> string end (* Sparse Dirac matrices as maps from Lorentz and Spinor indices to complex numbers. This is supposed to be independent of the representation. *) module type Dirac = sig val scalar : int -> int -> Complex.t' val vector : int -> int -> int -> Complex.t' val tensor : int -> int -> int -> int -> Complex.t' val axial : int -> int -> int -> Complex.t' val pseudo : int -> int -> Complex.t' end (* Dirac matrices as tables of nonzero entries. There will be one concrete Module per realization. *) module type Dirac_Matrices = sig type t = (int * int * Complex.t') list val scalar : t val vector : (int * t) list val tensor : (int * int * t) list val axial : (int * t) list val pseudo : t end (* E.\,g.~the chiral representation: *) module Chiral : Dirac_Matrices (* Here's the functor to create the maps corresponding to a given realization. *) module Dirac : functor (M : Dirac_Matrices) -> Dirac end module Lorentz : Lorentz = struct type index = | I of int (* $\mu_0,\mu_1,\ldots$, not $0,1,2,3$ *) | F of field let map_index fi ff = function | I i -> I (fi i) | F i -> F (ff i) let indices = function | I i -> [i] | F _ -> [] (* Is the following level of type checks useful or redundant? *) (* TODO: should we also support a [tensor] like $F_{\mu_1\mu_2}$? *) type vector = Vector of index type spinor = Spinor of index type conjspinor = ConjSpinor of index let map_vector fi ff (Vector i) = Vector (map_index fi ff i) let map_spinor fi ff (Spinor i) = Spinor (map_index fi ff i) let map_conjspinor fi ff (ConjSpinor i) = ConjSpinor (map_index fi ff i) let vector_ok context = function | Vector (I _) -> (* we could perform additional checks! *) true | Vector (F i) -> begin match Field.get context.lorentz_reps i with | Coupling.Vector -> true | Coupling.Vectorspinor -> failwith "Lorentz.vector_ok: incomplete" | _ -> false end let spinor_ok context = function | Spinor (I _) -> (* we could perfrom additional checks! *) true | Spinor (F i) -> begin match Field.get context.lorentz_reps i with | Coupling.Spinor -> true | Coupling.Vectorspinor | Coupling.Majorana -> failwith "Lorentz.spinor_ok: incomplete" | _ -> false end let conjspinor_ok context = function | ConjSpinor (I _) -> (* we could perform additional checks! *) true | ConjSpinor (F i) -> begin match Field.get context.lorentz_reps i with | Coupling.ConjSpinor -> true | Coupling.Vectorspinor | Coupling.Majorana -> failwith "Lorentz.conjspinor_ok: incomplete" | _ -> false end (* Note that [distinct2 i j] is automatically guaranteed for Dirac spinors, because the $\bar\psi$ and $\psi$ can not appear in the same slot. This is however not the case for Weyl and Majorana spinors. *) let spinor_sandwitch_ok context i j = conjspinor_ok context i && spinor_ok context j type primitive = | G of vector * vector | E of vector * vector * vector * vector | K of vector * field | S of conjspinor * spinor | V of vector * conjspinor * spinor | T of vector * vector * conjspinor * spinor | A of vector * conjspinor * spinor | P of conjspinor * spinor let map_primitive fvi fvf fsi fsf fci fcf = function | G (mu, nu) -> G (map_vector fvi fvf mu, map_vector fvi fvf nu) | E (mu, nu, rho, sigma) -> E (map_vector fvi fvf mu, map_vector fvi fvf nu, map_vector fvi fvf rho, map_vector fvi fvf sigma) | K (mu, i) -> K (map_vector fvi fvf mu, fvf i) | S (i, j) -> S (map_conjspinor fci fcf i, map_spinor fsi fsf j) | V (mu, i, j) -> V (map_vector fvi fvf mu, map_conjspinor fci fcf i, map_spinor fsi fsf j) | T (mu, nu, i, j) -> T (map_vector fvi fvf mu, map_vector fvi fvf nu, map_conjspinor fci fcf i, map_spinor fsi fsf j) | A (mu, i, j) -> A (map_vector fvi fvf mu, map_conjspinor fci fcf i, map_spinor fsi fsf j) | P (i, j) -> P (map_conjspinor fci fcf i, map_spinor fsi fsf j) let primitive_ok context = function | G (mu, nu) -> distinct2 mu nu && vector_ok context mu && vector_ok context nu | E (mu, nu, rho, sigma) -> let i = [mu; nu; rho; sigma] in distinct i && List.for_all (vector_ok context) i | K (mu, i) -> vector_ok context mu | S (i, j) | P (i, j) -> spinor_sandwitch_ok context i j | V (mu, i, j) | A (mu, i, j) -> vector_ok context mu && spinor_sandwitch_ok context i j | T (mu, nu, i, j) -> vector_ok context mu && vector_ok context nu && spinor_sandwitch_ok context i j let primitive_vector_indices = function | G (Vector mu, Vector nu) | T (Vector mu, Vector nu, _, _) -> indices mu @ indices nu | E (Vector mu, Vector nu, Vector rho, Vector sigma) -> indices mu @ indices nu @ indices rho @ indices sigma | K (Vector mu, _) | V (Vector mu, _, _) | A (Vector mu, _, _) -> indices mu | S (_, _) | P (_, _) -> [] let vector_indices p = ThoList.flatmap primitive_vector_indices p let primitive_spinor_indices = function | G (_, _) | E (_, _, _, _) | K (_, _) -> [] | S (_, Spinor alpha) | V (_, _, Spinor alpha) | T (_, _, _, Spinor alpha) | A (_, _, Spinor alpha) | P (_, Spinor alpha) -> indices alpha let spinor_indices p = ThoList.flatmap primitive_spinor_indices p let primitive_conjspinor_indices = function | G (_, _) | E (_, _, _, _) | K (_, _) -> [] | S (ConjSpinor alpha, _) | V (_, ConjSpinor alpha, _) | T (_, _, ConjSpinor alpha, _) | A (_, ConjSpinor alpha, _) | P (ConjSpinor alpha, _) -> indices alpha let conjspinor_indices p = ThoList.flatmap primitive_conjspinor_indices p let vector_contraction_ok p = let c = ThoList.classify (vector_indices p) in print_endline (String.concat ", " (List.map (fun (n, i) -> string_of_int n ^ " * " ^ string_of_int i) c)); flush stdout; let res = List.for_all (fun (n, _) -> n = 2) c in res let two_of_each indices p = List.for_all (fun (n, _) -> n = 2) (ThoList.classify (indices p)) let vector_contraction_ok = two_of_each vector_indices let spinor_contraction_ok = two_of_each spinor_indices let conjspinor_contraction_ok = two_of_each conjspinor_indices let contraction_ok p = vector_contraction_ok p && spinor_contraction_ok p && conjspinor_contraction_ok p type tensor = int * primitive list let map_tensor fvi fvf fsi fsf fci fcf (factor, primitives) = (factor, List.map (map_primitive fvi fvf fsi fsf fci fcf ) primitives) let tensor_ok context (_, primitives) = List.for_all (primitive_ok context) primitives && contraction_ok primitives module Complex = struct type t = int * int type t' = Z | O | M | I | J | C of int * int let to_fortran = function | Z -> "(0,0)" | O -> "(1,0)" | M -> "(-1,0)" | I -> "(0,1)" | J -> "(0,-1)" | C (r, i) -> "(" ^ string_of_int r ^ "," ^ string_of_int i ^ ")" end module type Dirac = sig val scalar : int -> int -> Complex.t' val vector : int -> int -> int -> Complex.t' val tensor : int -> int -> int -> int -> Complex.t' val axial : int -> int -> int -> Complex.t' val pseudo : int -> int -> Complex.t' end module type Dirac_Matrices = sig type t = (int * int * Complex.t') list val scalar : t val vector : (int * t) list val tensor : (int * int * t) list val axial : (int * t) list val pseudo : t end module Chiral : Dirac_Matrices = struct type t = (int * int * Complex.t') list let scalar = [ (1, 1, Complex.O); (2, 2, Complex.O); (3, 3, Complex.O); (4, 4, Complex.O) ] let vector = [ (0, [ (1, 4, Complex.O); (4, 1, Complex.O); (2, 3, Complex.M); (3, 2, Complex.M) ]); (1, [ (1, 3, Complex.O); (3, 1, Complex.O); (2, 4, Complex.M); (4, 2, Complex.M) ]); (2, [ (1, 3, Complex.I); (3, 1, Complex.I); (2, 4, Complex.I); (4, 2, Complex.I) ]); (3, [ (1, 4, Complex.M); (4, 1, Complex.M); (2, 3, Complex.M); (3, 2, Complex.M) ]) ] let tensor = [ (* TODO!!! *) ] let axial = [ (0, [ (1, 4, Complex.M); (4, 1, Complex.O); (2, 3, Complex.O); (3, 2, Complex.M) ]); (1, [ (1, 3, Complex.M); (3, 1, Complex.O); (2, 4, Complex.O); (4, 2, Complex.M) ]); (2, [ (1, 3, Complex.J); (3, 1, Complex.I); (2, 4, Complex.J); (4, 2, Complex.I) ]); (3, [ (1, 4, Complex.O); (4, 1, Complex.M); (2, 3, Complex.O); (3, 2, Complex.M) ]) ] let pseudo = [ (1, 1, Complex.M); (2, 2, Complex.M); (3, 3, Complex.O); (4, 4, Complex.O) ] end module Dirac (M : Dirac_Matrices) : Dirac = struct module Map2 = Map.Make (struct type t = int * int - let compare = Pervasives.compare + let compare = pcompare end) let init2 triples = List.fold_left (fun acc (i, j, e) -> Map2.add (i, j) e acc) Map2.empty triples let bounds_check2 i j = if i < 1 || i > 4 || j < 0 || j > 4 then invalid_arg "Chiral.bounds_check2" let lookup2 map i j = bounds_check2 i j; try Map2.find (i, j) map with Not_found -> Complex.Z module Map3 = Map.Make (struct type t = int * (int * int) - let compare = Pervasives.compare + let compare = pcompare end) let init3 quadruples = List.fold_left (fun acc (mu, gamma) -> List.fold_right (fun (i, j, e) -> Map3.add (mu, (i, j)) e) gamma acc) Map3.empty quadruples let bounds_check3 mu i j = bounds_check2 i j; if mu < 0 || mu > 3 then invalid_arg "Chiral.bounds_check3" let lookup3 map mu i j = bounds_check3 mu i j; try Map3.find (mu, (i, j)) map with Not_found -> Complex.Z module Map4 = Map.Make (struct type t = int * int * (int * int) - let compare = Pervasives.compare + let compare = pcompare end) let init4 quadruples = List.fold_left (fun acc (mu, nu, gamma) -> List.fold_right (fun (i, j, e) -> Map4.add (mu, nu, (i, j)) e) gamma acc) Map4.empty quadruples let bounds_check4 mu nu i j = bounds_check3 nu i j; if mu < 0 || mu > 3 then invalid_arg "Chiral.bounds_check4" let lookup4 map mu nu i j = bounds_check4 mu nu i j; try Map4.find (mu, nu, (i, j)) map with Not_found -> Complex.Z let scalar_map = init2 M.scalar let vector_map = init3 M.vector let tensor_map = init4 M.tensor let axial_map = init3 M.axial let pseudo_map = init2 M.pseudo let scalar = lookup2 scalar_map let vector = lookup3 vector_map let tensor mu nu i j = lookup4 tensor_map mu nu i j let tensor mu nu i j = failwith "tensor: incomplete" let axial = lookup3 axial_map let pseudo = lookup2 pseudo_map end end module type Color = sig module Index : Index type index = Index.t type color_rep = F of field | C of field | A of field type primitive = | D of field * field | E of field * field * field (* only for $SU(3)$ *) | T of field * field * field | F of field * field * field val map_primitive : (field -> field) -> primitive -> primitive val primitive_indices : primitive -> field list val indices : primitive list -> field list type tensor = int * primitive list val map_tensor : (field -> field) -> 'a * primitive list -> 'a * primitive list val tensor_ok : context -> 'a * primitive list -> bool end module Color : Color = struct module Index : Index = struct type t = int let of_int i = i let to_int i = i end (* $a_0,a_1,\ldots$, not $0,1,\ldots$ *) type index = Index.t type color_rep = | F of field | C of field | A of field type primitive = | D of field * field | E of field * field * field | T of field * field * field | F of field * field * field let map_primitive f = function | D (i, j) -> D (f i, f j) | E (i, j, k) -> E (f i, f j, f k) | T (a, i, j) -> T (f a, f i, f j) | F (a, b, c) -> F (f a, f b, f c) let primitive_ok ctx = function | D (i, j) -> distinct2 i j && (match Field.get ctx.color_reps i, Field.get ctx.color_reps j with | Color.SUN (n1), Color.SUN (n2) -> n1 = - n2 && n2 > 0 | _, _ -> false) | E (i, j, k) -> distinct3 i j k && (match Field.get ctx.color_reps i, Field.get ctx.color_reps j, Field.get ctx.color_reps k with | Color.SUN (n1), Color.SUN (n2), Color.SUN (n3) -> n1 = 3 && n2 = 3 && n3 = 3 || n1 = -3 && n2 = -3 && n3 = -3 | _, _, _ -> false) | T (a, i, j) -> distinct3 a i j && (match Field.get ctx.color_reps a, Field.get ctx.color_reps i, Field.get ctx.color_reps j with | Color.AdjSUN(n1), Color.SUN (n2), Color.SUN (n3) -> n1 = n3 && n2 = - n3 && n3 > 0 | _, _, _ -> false) | F (a, b, c) -> distinct3 a b c && (match Field.get ctx.color_reps a, Field.get ctx.color_reps b, Field.get ctx.color_reps c with | Color.AdjSUN(n1), Color.AdjSUN (n2), Color.AdjSUN (n3) -> n1 = n2 && n2 = n3 && n1 > 0 | _, _, _ -> false) let primitive_indices = function | D (_, _) -> [] | E (_, _, _) -> [] | T (a, _, _) -> [a] | F (a, b, c) -> [a; b; c] let indices p = ThoList.flatmap primitive_indices p let contraction_ok p = List.for_all (fun (n, _) -> n = 2) (ThoList.classify (indices p)) type tensor = int * primitive list let map_tensor f (factor, primitives) = (factor, List.map (map_primitive f) primitives) let tensor_ok context (_, primitives) = List.for_all (primitive_ok context) primitives end type t = { fields : string array; lorentz : Lorentz.tensor list; color : Color.tensor list } module Test (M : Model.T) : Test = struct module Permutation = Permutation.Default let context_of_flavors flavors = { arity = Array.length flavors; lorentz_reps = Array.map M.lorentz flavors; color_reps = Array.map M.color flavors } let context_of_flavor_names names = context_of_flavors (Array.map M.flavor_of_string names) let context_of_vertex v = context_of_flavor_names v.fields let ok v = let context = context_of_vertex v in List.for_all (Lorentz.tensor_ok context) v.lorentz && List.for_all (Color.tensor_ok context) v.color module PM = Partial.Make (struct type t = field let compare = compare end) let id x = x let permute v p = let context = context_of_vertex v in let sorted = List.map (Field.of_int context) (ThoList.range 0 (Array.length v.fields - 1)) in let permute = PM.apply (PM.of_lists sorted (List.map (Field.of_int context) p)) in { fields = Permutation.array (Permutation.of_list p) v.fields; lorentz = List.map (Lorentz.map_tensor id permute id permute id permute) v.lorentz; color = List.map (Color.map_tensor permute) v.color } let permutations v = List.map (permute v) (Combinatorics.permute (ThoList.range 0 (Array.length v.fields - 1))) let wf_declaration flavor = match M.lorentz (M.flavor_of_string flavor) with | Coupling.Vector -> "vector" | Coupling.Spinor -> "spinor" | Coupling.ConjSpinor -> "conjspinor" | _ -> failwith "wf_declaration: incomplete" module Chiral = Lorentz.Dirac(Lorentz.Chiral) let write_fusion v = match Array.to_list v.fields with | lhs :: rhs -> let name = lhs ^ "_of_" ^ String.concat "_" rhs in let momenta = List.map (fun n -> "k_" ^ n) rhs in Printf.printf "pure function %s (%s) result (%s)\n" name (String.concat ", " (List.flatten (List.map2 (fun wf p -> [wf; p]) rhs momenta))) lhs; Printf.printf " type(%s) :: %s\n" (wf_declaration lhs) lhs; List.iter (fun wf -> Printf.printf " type(%s), intent(in) :: %s\n" (wf_declaration wf) wf) rhs; List.iter (Printf.printf " type(momentum), intent(in) :: %s\n") momenta; let rhs1 = List.hd rhs and rhs2 = List.hd (List.tl rhs) in begin match M.lorentz (M.flavor_of_string lhs) with | Coupling.Vector -> begin for mu = 0 to 3 do Printf.printf " %s(%d) =" lhs mu; for i = 1 to 4 do for j = 1 to 4 do match Chiral.vector mu i j with | Lorentz.Complex.Z -> () | c -> Printf.printf " + %s*%s(%d)*%s(%d)" (Lorentz.Complex.to_fortran c) rhs1 i rhs2 j done done; Printf.printf "\n" done end; | Coupling.Spinor | Coupling.ConjSpinor -> begin for i = 1 to 4 do Printf.printf " %s(%d) =" lhs i; for mu = 0 to 3 do for j = 1 to 4 do match Chiral.vector mu i j with | Lorentz.Complex.Z -> () | c -> Printf.printf " + %s*%s(%d)*%s(%d)" (Lorentz.Complex.to_fortran c) rhs1 mu rhs2 j done done; Printf.printf "\n" done end; | _ -> failwith "write_fusion: incomplete" end; Printf.printf "end function %s\n" name; () | [] -> () let write_fusions v = List.iter write_fusion (permutations v) (* Testing: *) let vector_field context i = Lorentz.Vector (Lorentz.F (Field.of_int context i)) let spinor_field context i = Lorentz.Spinor (Lorentz.F (Field.of_int context i)) let conjspinor_field context i = Lorentz.ConjSpinor (Lorentz.F (Field.of_int context i)) let mu = Lorentz.Vector (Lorentz.I 0) and nu = Lorentz.Vector (Lorentz.I 1) let tbar_gl_t = [| "tbar"; "gl"; "t" |] let context = context_of_flavor_names tbar_gl_t let vector_current_ok = { fields = tbar_gl_t; lorentz = [ (1, [Lorentz.V (vector_field context 1, conjspinor_field context 0, spinor_field context 2)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let vector_current_vector_misplaced = { fields = tbar_gl_t; lorentz = [ (1, [Lorentz.V (vector_field context 2, conjspinor_field context 0, spinor_field context 2)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let vector_current_spinor_misplaced = { fields = tbar_gl_t; lorentz = [ (1, [Lorentz.V (vector_field context 1, conjspinor_field context 0, spinor_field context 1)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let vector_current_conjspinor_misplaced = { fields = tbar_gl_t; lorentz = [ (1, [Lorentz.V (vector_field context 1, conjspinor_field context 1, spinor_field context 2)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let vector_current_out_of_bounds () = { fields = tbar_gl_t; lorentz = [ (1, [Lorentz.V (mu, conjspinor_field context 3, spinor_field context 2)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let vector_current_color_mismatch = let names = [| "t"; "gl"; "t" |] in let context = context_of_flavor_names names in { fields = names; lorentz = [ (1, [Lorentz.V (mu, conjspinor_field context 0, spinor_field context 2)]) ]; color = [ (1, [Color.T (Field.of_int context 1, Field.of_int context 0, Field.of_int context 2)])] } let wwzz = [| "W+"; "W-"; "Z"; "Z" |] let context = context_of_flavor_names wwzz let anomalous_couplings = { fields = wwzz; lorentz = [ (1, [ Lorentz.K (mu, Field.of_int context 0); Lorentz.K (mu, Field.of_int context 1) ]) ]; color = [ ] } let anomalous_couplings_index_mismatch = { fields = wwzz; lorentz = [ (1, [ Lorentz.K (mu, Field.of_int context 0); Lorentz.K (nu, Field.of_int context 1) ]) ]; color = [ ] } exception Inconsistent_vertex let example () = if not (ok vector_current_ok) then begin raise Inconsistent_vertex end; write_fusions vector_current_ok open OUnit let vertex_indices_ok = "indices/ok" >:: (fun () -> List.iter (fun v -> assert_bool "vector_current" (ok v)) (permutations vector_current_ok)) let vertex_indices_broken = "indices/broken" >:: (fun () -> assert_bool "vector misplaced" (not (ok vector_current_vector_misplaced)); assert_bool "conjugate spinor misplaced" (not (ok vector_current_spinor_misplaced)); assert_bool "conjugate spinor misplaced" (not (ok vector_current_conjspinor_misplaced)); assert_raises (Field.Out_of_range 3) vector_current_out_of_bounds; assert_bool "color mismatch" (not (ok vector_current_color_mismatch))) let anomalous_couplings_ok = "anomalous_couplings/ok" >:: (fun () -> assert_bool "anomalous couplings" (ok anomalous_couplings)) let anomalous_couplings_broken = "anomalous_couplings/broken" >:: (fun () -> assert_bool "anomalous couplings" (not (ok anomalous_couplings_index_mismatch))) let suite = "Vertex" >::: [vertex_indices_ok; vertex_indices_broken; anomalous_couplings_ok; anomalous_couplings_broken] end Index: trunk/omega/src/sets.ml =================================================================== --- trunk/omega/src/sets.ml (revision 8305) +++ trunk/omega/src/sets.ml (revision 8306) @@ -1,27 +1,34 @@ (* sets.ml -- Copyright (C) 2019- by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module String = Set.Make (struct type t = string let compare = compare end) +module String_Caseless = + Set.Make + (struct + type t = string + let compare = ThoString.compare_caseless + end) + module Int = Set.Make (struct type t = int let compare = compare end) Index: trunk/omega/src/dump_ufo.sh =================================================================== --- trunk/omega/src/dump_ufo.sh (revision 8305) +++ trunk/omega/src/dump_ufo.sh (revision 8306) @@ -1,31 +1,31 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script takes TO's directory structure for granted. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## jobs=12 UFO_SM=$HOME/physics/SM/ UFO_MSSM=$HOME/physics/MSSM_UFO/ UFO_SMEFT=$HOME/physics/SMEFTsim_A_U35_alphaScheme_UFO_v2_1/ UFO_SMEFT=$HOME/physics/SMEFT_mW_UFO/ root=$HOME/physics/whizard -build=$root/_build +build=$root/_build/default omega=omega_UFO case X"$1" in X"-SM") UFO=$UFO_SM; shift;; X"-SMEFT") UFO=$UFO_SMEFT; shift;; X"-MSSM") UFO=$UFO_MSSM; omega=omega_UFO_Majorana; shift;; X"-X") UFO="$2"; shift 2;; *) UFO=$UFO_SM;; esac OCAMLFLAGS="-w -D -warn-error +P" make OCAMLFLAGS="$OCAMLFLAGS" -j $jobs -C $build/omega/src || exit 1 make -j $jobs -C $build/omega/bin $omega.opt || exit 1 $build/omega/bin/$omega.opt -model:UFO_dir $UFO -model:dump -model:exec "$@" Index: trunk/omega/src/thoString.ml =================================================================== --- trunk/omega/src/thoString.ml (revision 8305) +++ trunk/omega/src/thoString.ml (revision 8306) @@ -1,118 +1,116 @@ (* thoString.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let strip_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then s else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then s else strip_prefix' (succ i) in strip_prefix' 0 let strip_prefix_star p s = let ls = String.length s in if ls < 1 then s else let rec strip_prefix_star' i = if i < ls then begin if p <> s.[i] then String.sub s i (ls - i) else strip_prefix_star' (succ i) end else "" in strip_prefix_star' 0 let strip_required_prefix p s = let lp = String.length p and ls = String.length s in if lp > ls then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else let rec strip_prefix' i = if i >= lp then String.sub s i (ls - i) else if p.[i] <> s.[i] then invalid_arg ("strip_required_prefix: expected `" ^ p ^ "' got `" ^ s ^ "'") else strip_prefix' (succ i) in strip_prefix' 0 let strip_from_first c s = try String.sub s 0 (String.index s c) with | Not_found -> s let strip_from_last c s = try String.sub s 0 (String.rindex s c) with | Not_found -> s let index_string pat s = let lpat = String.length pat and ls = String.length s in if lpat = 0 then 0 else let rec index_string' n = let i = String.index_from s n pat.[0] in if i + lpat > ls then raise Not_found else if String.compare pat (String.sub s i lpat) = 0 then i else index_string' (succ i) in index_string' 0 let quote s = if String.contains s ' ' || String.contains s '\n' then begin if String.contains s '"' then "'" ^ s ^ "'" else "\"" ^ s ^ "\"" end else s -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) +let uppercase = String.uppercase +let lowercase = String.lowercase + +let compare_caseless s1 s2 = + String.compare (lowercase s1) (lowercase s2) Index: trunk/omega/src/thoList.ml =================================================================== --- trunk/omega/src/thoList.ml (revision 8305) +++ trunk/omega/src/thoList.ml (revision 8306) @@ -1,512 +1,520 @@ (* thoList.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + let rec hdn n l = if n <= 0 then [] else match l with | x :: rest -> x :: hdn (pred n) rest | [] -> invalid_arg "ThoList.hdn" let rec tln n l = if n <= 0 then l else match l with | _ :: rest -> tln (pred n) rest | [] -> invalid_arg "ThoList.tln" let rec splitn' n l1_rev l2 = if n <= 0 then (List.rev l1_rev, l2) else match l2 with | x :: l2' -> splitn' (pred n) (x :: l1_rev) l2' | [] -> invalid_arg "ThoList.splitn n > len" let splitn n l = if n < 0 then invalid_arg "ThoList.splitn n < 0" else splitn' n [] l let split_last l = match List.rev l with | [] -> invalid_arg "ThoList.split_last []" | ln :: l12_rev -> (List.rev l12_rev, ln) (* This is [splitn'] all over again, but without the exception. *) let rec chopn'' n l1_rev l2 = if n <= 0 then (List.rev l1_rev, l2) else match l2 with | x :: l2' -> chopn'' (pred n) (x :: l1_rev) l2' | [] -> (List.rev l1_rev, []) let rec chopn' n ll_rev = function | [] -> List.rev ll_rev | l -> begin match chopn'' n [] l with | [], [] -> List.rev ll_rev | l1, [] -> List.rev (l1 :: ll_rev) | l1, l2 -> chopn' n (l1 :: ll_rev) l2 end let chopn n l = if n <= 0 then invalid_arg "ThoList.chopn n <= 0" else chopn' n [] l (* Find a member [a] in the list [l] and return the cyclically permuted list with [a] as head. *) let cycle_until a l = let rec cycle_until' acc = function | [] -> raise Not_found | a' :: l' as al' -> if a' = a then al' @ List.rev acc else cycle_until' (a' :: acc) l' in cycle_until' [] l let rec cycle' i acc l = if i <= 0 then l @ List.rev acc else match l with | [] -> invalid_arg "ThoList.cycle" - | a' :: l' as al' -> + | a' :: l' -> cycle' (pred i) (a' :: acc) l' let cycle n l = if n < 0 then invalid_arg "ThoList.cycle" else cycle' n [] l let of_subarray n1 n2 a = let rec of_subarray' n1 n2 = if n1 > n2 then [] else a.(n1) :: of_subarray' (succ n1) n2 in of_subarray' (max 0 n1) (min n2 (pred (Array.length a))) let range ?(stride=1) n1 n2 = if stride <= 0 then invalid_arg "ThoList.range: stride <= 0" else let rec range' n = if n > n2 then [] else n :: range' (n + stride) in range' n1 (* Tail recursive: *) let enumerate ?(stride=1) n l = let _, l_rev = List.fold_left (fun (i, acc) a -> (i + stride, (i, a) :: acc)) (n, []) l in List.rev l_rev (* Take the elements of [list] that satisfy [predicate] and form a list of pairs of an offset into the original list and the element with the offsets starting from [offset]. NB: the order of the returned alist is not specified! *) let alist_of_list ?(predicate=(fun _ -> true)) ?(offset=0) list = let _, alist = List.fold_left (fun (n, acc) x -> (succ n, if predicate x then (n, x) :: acc else acc)) (offset, []) list in alist (* This is \emph{not} tail recursive! *) let rec flatmap f = function | [] -> [] | x :: rest -> f x @ flatmap f rest (* This is! *) let rev_flatmap f l = let rec rev_flatmap' acc f = function | [] -> acc | x :: rest -> rev_flatmap' (List.rev_append (f x) acc) f rest in rev_flatmap' [] f l let fold_left2 f acc lists = List.fold_left (List.fold_left f) acc lists let fold_right2 f lists acc = List.fold_right (List.fold_right f) lists acc let iteri f start list = ignore (List.fold_left (fun i a -> f i a; succ i) start list) let iteri2 f start_outer star_inner lists = iteri (fun j -> iteri (f j) star_inner) start_outer lists let mapi f start list = let next, list' = List.fold_left (fun (i, acc) a -> (succ i, f i a :: acc)) (start, []) list in List.rev list' (* Is there a more efficient implementation? *) let transpose lists = let rec transpose' rest = if List.for_all ((=) []) rest then [] else List.map List.hd rest :: transpose' (List.map List.tl rest) in try transpose' lists with - | Failure "tl" -> invalid_arg "ThoList.transpose: not rectangular" + | Failure s -> + if s = "tl" then + invalid_arg "ThoList.transpose: not rectangular" + else + failwith ("ThoList.transpose: unexpected Failure(" ^ s ^ ")") -let compare ?(cmp=Pervasives.compare) l1 l2 = +let compare ?(cmp=pcompare) l1 l2 = let rec compare' l1' l2' = match l1', l2' with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | n1 :: r1, n2 :: r2 -> let c = cmp n1 n2 in if c <> 0 then c else compare' r1 r2 in compare' l1 l2 let rec uniq' x = function | [] -> [] | x' :: rest -> if x' = x then uniq' x rest else x' :: uniq' x' rest let uniq = function | [] -> [] | x :: rest -> x :: uniq' x rest let rec homogeneous = function | [] | [_] -> true | a1 :: (a2 :: _ as rest) -> if a1 <> a2 then false else homogeneous rest let rec pairs' acc = function | [] -> acc | [x] -> invalid_arg "pairs: odd number of elements" | x :: y :: indices -> if x <> y then invalid_arg "pairs: not in pairs" else begin match acc with | [] -> pairs' [x] indices | x' :: _ -> if x = x' then invalid_arg "pairs: more than twice" else pairs' (x :: acc) indices end let pairs l = - pairs' [] (List.sort Pervasives.compare l) + pairs' [] (List.sort pcompare l) (* If we needed it, we could use a polymorphic version of [Set] to speed things up from~$O(n^2)$ to~$O(n\ln n)$. But not before it matters somewhere \ldots *) let classify l = let rec add_to_class a = function | [] -> [1, a] | (n, a') :: rest -> if a = a' then (succ n, a) :: rest else (n, a') :: add_to_class a rest in let rec classify' cl = function | [] -> cl | a :: rest -> classify' (add_to_class a cl) rest in classify' [] l let rec factorize l = let rec add_to_class x y = function | [] -> [(x, [y])] | (x', ys) :: rest -> if x = x' then (x, y :: ys) :: rest else (x', ys) :: add_to_class x y rest in let rec factorize' fl = function | [] -> fl | (x, y) :: rest -> factorize' (add_to_class x y fl) rest in List.map (fun (x, ys) -> (x, List.rev ys)) (factorize' [] l) let rec clone n x = if n < 0 then invalid_arg "ThoList.clone" else if n = 0 then [] else x :: clone (pred n) x let interleave f list = let rec interleave' rev_head tail = let rev_head' = List.rev_append (f rev_head tail) rev_head in match tail with | [] -> List.rev rev_head' | x :: tail' -> interleave' (x :: rev_head') tail' in interleave' [] list let interleave_nearest f list = interleave (fun head tail -> match head, tail with | h :: _, t :: _ -> f h t | _ -> []) list let rec rev_multiply n rl l = if n < 0 then invalid_arg "ThoList.multiply" else if n = 0 then [] else List.rev_append rl (rev_multiply (pred n) rl l) let multiply n l = rev_multiply n (List.rev l) l exception Overlapping_indices exception Out_of_bounds let iset_of_list list = List.fold_right Sets.Int.add list Sets.Int.empty let iset_list_union list = List.fold_right Sets.Int.union list Sets.Int.empty let complement_index_sets n index_set_lists = let index_sets = List.map iset_of_list index_set_lists in let index_set = iset_list_union index_sets in let size_index_sets = List.fold_left (fun acc s -> Sets.Int.cardinal s + acc) 0 index_sets in if size_index_sets <> Sets.Int.cardinal index_set then raise Overlapping_indices else if Sets.Int.exists (fun i -> i < 0 || i >= n) index_set then raise Overlapping_indices else match Sets.Int.elements (Sets.Int.diff (iset_of_list (range 0 (pred n))) index_set) with | [] -> index_set_lists | complement -> complement :: index_set_lists let sort_section cmp array index_set = List.iter2 (Array.set array) index_set (List.sort cmp (List.map (Array.get array) index_set)) let partitioned_sort cmp index_sets list = let array = Array.of_list list in List.fold_left (fun () -> sort_section cmp array) () (complement_index_sets (List.length list) index_sets); Array.to_list array -let ariadne_sort ?(cmp=Pervasives.compare) list = +let ariadne_sort ?(cmp=pcompare) list = let sorted = List.sort (fun (n1, a1) (n2, a2) -> cmp a1 a2) (enumerate 0 list) in (List.map snd sorted, List.map fst sorted) let ariadne_unsort (sorted, indices) = List.map snd (List.sort - (fun (n1, a1) (n2, a2) -> Pervasives.compare n1 n2) + (fun (n1, a1) (n2, a2) -> pcompare n1 n2) (List.map2 (fun n a -> (n, a)) indices sorted)) -let lexicographic ?(cmp=Pervasives.compare) l1 l2 = +let lexicographic ?(cmp=pcompare) 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) (* 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 = List.fold_left (fun acc x1 -> if List.mem x1 l2 then x1 :: acc else acc) [] l1 let complement l1 = function | [] -> l1 | l2 -> if List.for_all (fun x -> List.mem x l1) l2 then List.filter (fun x -> not (List.mem x l2)) l1 else invalid_arg "ThoList.complement" let to_string a2s alist = "[" ^ String.concat "; " (List.map a2s alist) ^ "]" let random_int_list imax n = let imax_plus = succ imax in Array.to_list (Array.init n (fun _ -> Random.int imax_plus)) module Test = struct open OUnit let suite_split = "split*" >::: [ "split_last []" >:: (fun () -> assert_raises (Invalid_argument "ThoList.split_last []") (fun () -> split_last [])); "split_last [1]" >:: (fun () -> assert_equal ([], 1) (split_last [1])); "split_last [2;3;1;4]" >:: (fun () -> assert_equal ([2;3;1], 4) (split_last [2;3;1;4])) ] let test_list = random_int_list 1000 100 let assert_equal_int_list = assert_equal ~printer:(to_string string_of_int) let suite_cycle = "cycle_until" >::: [ "cycle (-1) [1;2;3]" >:: (fun () -> assert_raises (Invalid_argument "ThoList.cycle") (fun () -> cycle 4 [1;2;3])); "cycle 4 [1;2;3]" >:: (fun () -> assert_raises (Invalid_argument "ThoList.cycle") (fun () -> cycle 4 [1;2;3])); "cycle 42 [...]" >:: (fun () -> let n = 42 in assert_equal_int_list (tln n test_list @ hdn n test_list) (cycle n test_list)); "cycle_until 1 []" >:: (fun () -> assert_raises (Not_found) (fun () -> cycle_until 1 [])); "cycle_until 1 [2;3;4]" >:: (fun () -> assert_raises (Not_found) (fun () -> cycle_until 1 [2;3;4])); "cycle_until 1 [1;2;3;4]" >:: (fun () -> assert_equal [1;2;3;4] (cycle_until 1 [1;2;3;4])); "cycle_until 3 [1;2;3;4]" >:: (fun () -> assert_equal [3;4;1;2] (cycle_until 3 [3;4;1;2])); "cycle_until 4 [1;2;3;4]" >:: (fun () -> assert_equal [4;1;2;3] (cycle_until 4 [4;1;2;3])) ] let suite_alist_of_list = "alist_of_list" >::: [ "simple" >:: (fun () -> assert_equal [(46, 4); (44, 2); (42, 0)] (alist_of_list ~predicate:(fun n -> n mod 2 = 0) ~offset:42 [0;1;2;3;4;5])) ] let suite_complement = "complement" >::: [ "simple" >:: (fun () -> assert_equal [2;4] (complement [1;2;3;4] [1; 3])); "empty" >:: (fun () -> assert_equal [1;2;3;4] (complement [1;2;3;4] [])); "failure" >:: (fun () -> assert_raises (Invalid_argument ("ThoList.complement")) (fun () -> complement (complement [1;2;3;4] [5]))) ] let suite = "ThoList" >::: [suite_split; suite_cycle; suite_alist_of_list; suite_complement] end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * compile-command:"ocamlc -o vertex thoList.ml{i,} pmap.ml{i,} vertex.ml" * End: i*) Index: trunk/omega/src/omega.ml =================================================================== --- trunk/omega/src/omega.ml (revision 8305) +++ trunk/omega/src/omega.ml (revision 8306) @@ -1,700 +1,696 @@ (* omega.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let (<<) f g x = f (g x) let (>>) f g x = g (f x) module P = Momentum.Default module P_Whizard = Momentum.DefaultW module type T = sig val main : unit -> unit type flavor val diagrams : flavor -> flavor -> flavor list -> ((flavor * Momentum.Default.t) * (flavor * Momentum.Default.t, flavor * Momentum.Default.t) Tree.t) list end module Make (Fusion_Maker : Fusion.Maker) (Target_Maker : Target.Maker) (M : Model.T) = struct module CM = Colorize.It(M) type flavor = M.flavor module Proc = Process.Make(M) (* \begin{dubious} We must have initialized the vertices \emph{before} applying [Fusion_Maker], at least if we want to continue using the vertex cache! \end{dubious} *) (* \begin{dubious} NB: this causes the constant initializers in [Fusion_Maker] more than once. Such side effects must be avoided if the initializers involve expensive computations. \emph{Relying on the fact that the functor will be called only once is not a good idea!} \end{dubious} *) module F = Fusion_Maker(P)(M) module CF = Fusion.Multi(Fusion_Maker)(P)(M) module T = Target_Maker(Fusion_Maker)(P)(M) module W = Whizard.Make(Fusion_Maker)(P)(P_Whizard)(M) module C = Cascade.Make(M)(P) module VSet = Set.Make (struct type t = F.constant Coupling.t let compare = compare end) (* FIXME: can be retired starting from O'Caml 4.02.0! *) let vset_of_list list = List.fold_right VSet.add list VSet.empty; (* For the phase space, we need asymmetric DAGs. HACK: since we will not use this to compute amplitudes, there's no need to supply the proper statistics module and we may assume Dirac fermions. HACK: for the phase space, we should be able to work on the uncolored model. *) module PHS = Fusion.Helac(struct let max_arity () = pred (M.max_degree ()) end)(P)(M) (* Form a ['a list] from a ['a option array], containing the elements that are not [None] in order. *) let opt_array_to_list a = let rec opt_array_to_list' acc i a = if i < 0 then acc else begin match a.(i) with | None -> opt_array_to_list' acc (pred i) a | Some x -> opt_array_to_list' (x :: acc) (pred i) a end in opt_array_to_list' [] (Array.length a - 1) a (* Return a list of [CF.amplitude list]s, corresponig to the diagrams for a specific color flow for each flavor combination. *) let amplitudes_by_flavor amplitudes = List.map opt_array_to_list (Array.to_list (CF.process_table amplitudes)) (* \begin{dubious} If we plan to distiguish different couplings later on, we can no long map all instances of [coupling option] in the tree to [None]. In this case, we will need to normalize different fusion orders [Coupling.fuse2], [Coupling.fuse3] or [Coupling.fusen], because they would otherwise lead to inequivalent diagrams. Unfortunately, this stuff packaged deep in [Fusion.Tagged_Coupling]. \end{dubious} *) (*i let strip_fuse' = function | Coupling.V3 (v, f, c) -> Coupling.V3 (v, Coupling.F12, c) | Coupling.V4 (v, f, c) -> Coupling.V4 (v, Coupling.F123, c) | Coupling.Vn (v, f, c) -> Coupling.Vn (v, [], c) let strip_fuse = function | Some c -> Some (strip_fuse' c) | None -> None i*) (* \begin{dubious} The [Tree.canonicalize] below should be necessary to remove topologically equivalent duplicates. \end{dubious} *) (* Take a [CF.amplitude list] assumed to correspond to the same external states after stripping the color and return a pair of the list of external particles and the corresponding Feynman diagrams without color. *) let wf1 amplitude = match F.externals amplitude with | wf :: _ -> wf | [] -> failwith "Omega.forest_sans_color: no external particles" let uniq l = ThoList.uniq (List.sort compare l) let forest_sans_color = function | amplitude :: _ as amplitudes -> let externals = F.externals amplitude in let prune_color wf = (F.flavor_sans_color wf, F.momentum_list wf) in let prune_color_and_couplings (wf, c) = (prune_color wf, None) in (List.map prune_color externals, uniq (List.map (fun t -> Tree.canonicalize (Tree.map prune_color_and_couplings prune_color t)) (ThoList.flatmap (fun a -> F.forest (wf1 a) a) amplitudes))) | [] -> ([], []) let dag_sans_color = function | amplitude :: _ as amplitudes -> - let prune_color wf = - (F.flavor_sans_color wf, F.momentum_list wf) in - let prune_color_and_couplings (wf, c) = - (prune_color wf, None) in let prune a = a in List.map prune amplitudes | [] -> [] let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let format_p wf = String.concat "" (List.map p2s (F.momentum_list wf)) let variable wf = M.flavor_to_string (F.flavor_sans_color wf) ^ "[" ^ format_p wf ^ "]" let variable' wf = CM.flavor_to_TeX (F.flavor wf) ^ "(" ^ format_p wf ^ ")" let feynmf_style propagator color = { Tree.style = begin match propagator with | Coupling.Prop_Feynman | Coupling.Prop_Gauge _ -> begin match color with | Color.AdjSUN _ -> Some ("gluon", "") | _ -> Some ("boson", "") end | Coupling.Prop_Col_Feynman -> Some ("gluon", "") | Coupling.Prop_Unitarity | Coupling.Prop_Rxi _ -> Some ("dbl_wiggly", "") | Coupling.Prop_Spinor | Coupling.Prop_ConjSpinor -> Some ("fermion", "") | _ -> None end; Tree.rev = begin match propagator with | Coupling.Prop_Spinor -> true | Coupling.Prop_ConjSpinor -> false | _ -> false end; Tree.label = None; Tree.tension = None } let header incoming outgoing = "$ " ^ String.concat " " (List.map (CM.flavor_to_TeX << F.flavor) incoming) ^ " \\to " ^ String.concat " " (List.map (CM.flavor_to_TeX << CM.conjugate << F.flavor) outgoing) ^ " $" let header_sans_color incoming outgoing = "$ " ^ String.concat " " (List.map (M.flavor_to_TeX << fst) incoming) ^ " \\to " ^ String.concat " " (List.map (M.flavor_to_TeX << M.conjugate << fst) outgoing) ^ " $" let diagram incoming tree = let fmf wf = let f = F.flavor wf in feynmf_style (CM.propagator f) (CM.color f) in Tree.map (fun (n, _) -> let n' = fmf n in if List.mem n incoming then { n' with Tree.rev = not n'.Tree.rev } else n') (fun l -> if List.mem l incoming then l else F.conjugate l) tree let diagram_sans_color incoming (tree) = let fmf (f, p) = feynmf_style (M.propagator f) (M.color f) in Tree.map (fun (n, c) -> let n' = fmf n in if List.mem n incoming then { n' with Tree.rev = not n'.Tree.rev } else n') (fun (f, p) -> if List.mem (f, p) incoming then (f, p) else (M.conjugate f, p)) tree let feynmf_set amplitude = match F.externals amplitude with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header incoming wfs; Tree.incoming = incoming; Tree.diagrams = List.map (diagram incoming) (F.forest wf1 amplitude) } | _ -> failwith "less than two external particles" let feynmf_set_sans_color (externals, trees) = match externals with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header_sans_color incoming wfs; Tree.incoming = incoming; Tree.diagrams = List.map (diagram_sans_color incoming) trees } | _ -> failwith "less than two external particles" let feynmf_set_sans_color_empty (externals, trees) = match externals with | wf1 :: wf2 :: wfs -> let incoming = [wf1; wf2] in { Tree.header = header_sans_color incoming wfs; Tree.incoming = incoming; Tree.diagrams = [] } | _ -> failwith "less than two external particles" let uncolored_colored amplitudes = { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes); Tree.inner = List.map feynmf_set amplitudes } let uncolored_only amplitudes = { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes); Tree.inner = [] } let colored_only amplitudes = { Tree.outer = feynmf_set_sans_color_empty (forest_sans_color amplitudes); Tree.inner = List.map feynmf_set amplitudes } let momentum_to_TeX (_, p) = String.concat "" (List.map p2s p) let wf_to_TeX (f, _ as wf) = M.flavor_to_TeX f ^ "(" ^ momentum_to_TeX wf ^ ")" let amplitudes_to_feynmf latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map uncolored_colored (amplitudes_by_flavor amplitudes)) let amplitudes_to_feynmf_sans_color latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map uncolored_only (amplitudes_by_flavor amplitudes)) let amplitudes_to_feynmf_color_only latex name amplitudes = Tree.feynmf_sets_wrapped latex name wf_to_TeX momentum_to_TeX variable' format_p (List.map colored_only (amplitudes_by_flavor amplitudes)) let debug (str, descr, opt, var) = [ "-warning:" ^ str, Arg.Unit (fun () -> var := (opt, false):: !var), " check " ^ descr ^ " and print warning on error"; "-error:" ^ str, Arg.Unit (fun () -> var := (opt, true):: !var), " check " ^ descr ^ " and terminate on error" ] let rec include_goldstones = function | [] -> false | (T.Gauge, _) :: _ -> true | _ :: rest -> include_goldstones rest let read_lines_rev file = let ic = open_in file in let rev_lines = ref [] in let rec slurp () = rev_lines := input_line ic :: !rev_lines; slurp () in try slurp () with | End_of_file -> close_in ic; !rev_lines let read_lines file = List.rev (read_lines_rev file) type cache_mode = | Cache_Default | Cache_Initialize of string let cache_option = ref Cache_Default let unphysical_polarization = ref None (* \thocwmodulesection{Main Program} *) let main () = (* Delay evaluation of [M.external_flavors ()]! *) let usage () = "usage: " ^ Sys.argv.(0) ^ " [options] [" ^ String.concat "|" (List.map M.flavor_to_string (ThoList.flatmap snd (M.external_flavors ()))) ^ "]" and rev_scatterings = ref [] and rev_decays = ref [] and cascades = ref [] and checks = ref [] and output_file = ref None and print_forest = ref false and template = ref false and diagrams_all = ref None and diagrams_sans_color = ref None and diagrams_color_only = ref None and diagrams_LaTeX = ref false and quiet = ref false and write = ref true and params = ref false and poles = ref false and dag_out = ref None and dag0_out = ref None and phase_space_out = ref None in Options.parse (Options.cmdline "-target:" T.options @ Options.cmdline "-model:" M.options @ Options.cmdline "-fusion:" CF.options @ ThoList.flatmap debug ["a", "arguments", T.All, checks; "n", "# of input arguments", T.Arguments, checks; "m", "input momenta", T.Momenta, checks; "g", "internal Ward identities", T.Gauge, checks] @ [("-o", Arg.String (fun s -> output_file := Some s), "file write to given file instead of /dev/stdout"); ("-scatter", Arg.String (fun s -> rev_scatterings := s :: !rev_scatterings), "expr in1 in2 -> out1 out2 ..."); ("-scatter_file", Arg.String (fun s -> rev_scatterings := read_lines_rev s @ !rev_scatterings), "name each line: in1 in2 -> out1 out2 ..."); ("-decay", Arg.String (fun s -> rev_decays := s :: !rev_decays), "expr in -> out1 out2 ..."); ("-decay_file", Arg.String (fun s -> rev_decays := read_lines_rev s @ !rev_decays), "name each line: in -> out1 out2 ..."); ("-cascade", Arg.String (fun s -> cascades := s :: !cascades), "expr select diagrams"); ("-initialize", Arg.String (fun s -> cache_option := Cache_Initialize s), "dir precompute lookup tables and store them in directory"); ("-unphysical", Arg.Int (fun i -> unphysical_polarization := Some i), "n use unphysical polarization for n-th particle / test WIs"); ("-template", Arg.Set template, " write a template for handwritten amplitudes"); ("-forest", Arg.Set print_forest, " Diagrammatic expansion"); ("-diagrams", Arg.String (fun s -> diagrams_sans_color := Some s), "file produce FeynMP output for Feynman diagrams"); ("-diagrams:c", Arg.String (fun s -> diagrams_color_only := Some s), "file produce FeynMP output for color flow diagrams"); ("-diagrams:C", Arg.String (fun s -> diagrams_all := Some s), "file produce FeynMP output for Feynman and color flow diagrams"); ("-diagrams_LaTeX", Arg.Set diagrams_LaTeX, " enclose FeynMP output in LaTeX wrapper"); ("-quiet", Arg.Set quiet, " don't print a summary"); ("-summary", Arg.Clear write, " print only a summary"); ("-params", Arg.Set params, " print the model parameters"); ("-poles", Arg.Set poles, " print the Monte Carlo poles"); ("-dag", Arg.String (fun s -> dag_out := Some s), " print minimal DAG"); ("-full_dag", Arg.String (fun s -> dag0_out := Some s), " print complete DAG"); ("-phase_space", Arg.String (fun s -> phase_space_out := Some s), " print minimal DAG for phase space")]) (*i ("-T", Arg.Int Topology.Binary.debug_triplet, ""); ("-P", Arg.Int Topology.Binary.debug_partition, "")]) i*) (fun _ -> prerr_endline (usage ()); exit 1) usage; let cmdline = String.concat " " (List.map ThoString.quote (Array.to_list Sys.argv)) in let output_channel = match !output_file with | None -> stdout | Some name -> open_out name in let processes = try ThoList.uniq (List.sort compare (match List.rev !rev_scatterings, List.rev !rev_decays with | [], [] -> [] | scatterings, [] -> Proc.expand_scatterings (List.map Proc.parse_scattering scatterings) | [], decays -> Proc.expand_decays (List.map Proc.parse_decay decays) | scatterings, decays -> invalid_arg "mixed scattering and decay!")) with | Invalid_argument s -> begin Printf.eprintf "O'Mega: invalid process specification: %s!\n" s; flush stderr; [] end in (* \begin{dubious} This is still crude. Eventually, we want to catch \emph{all} exceptions and write an empty (but compilable) amplitude unless one of the special options is selected. \end{dubious} *) begin match processes, !cache_option, !params with | [], Cache_Initialize dir, false -> F.initialize_cache dir; exit 0 | _, _, true -> if !write then T.parameters_to_channel output_channel; exit 0 | [], _, false -> if !write then T.amplitudes_to_channel cmdline output_channel !checks CF.empty; exit 0 | _, _, false -> let selectors = let fin, fout = List.hd processes in C.to_selectors (C.of_string_list (List.length fin + List.length fout) !cascades) in let amplitudes = try begin match F.check_charges () with | [] -> () | violators -> let violator_strings = String.concat ", " (List.map (fun flist -> "(" ^ String.concat "," (List.map M.flavor_to_string flist) ^ ")") violators) in failwith ("charge violating vertices: " ^ violator_strings) end; CF.amplitudes (include_goldstones !checks) !unphysical_polarization CF.no_exclusions selectors processes with | Fusion.Majorana -> begin Printf.eprintf "O'Mega: found Majorana fermions: use a supporting binary!\n"; flush stderr; CF.empty; end | exc -> begin Printf.eprintf "O'Mega: exception %s in amplitude construction!\n" (Printexc.to_string exc); flush stderr; CF.empty; end in if !write then T.amplitudes_to_channel cmdline output_channel !checks amplitudes; if not !quiet then begin List.iter (fun amplitude -> Printf.eprintf "SUMMARY: %d fusions, %d propagators" (F.count_fusions amplitude) (F.count_propagators amplitude); flush stderr; Printf.eprintf ", %d diagrams" (F.count_diagrams amplitude); Printf.eprintf "\n") (CF.processes amplitudes); let couplings = List.fold_left (fun acc p -> let fusions = ThoList.flatmap F.rhs (F.fusions p) and brakets = ThoList.flatmap F.ket (F.brakets p) in let couplings = vset_of_list (List.map F.coupling (fusions @ brakets)) in VSet.union acc couplings) VSet.empty (CF.processes amplitudes) in Printf.eprintf "SUMMARY: %d vertices\n" (VSet.cardinal couplings); let ufo_couplings = VSet.fold (fun v acc -> match v with | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) -> Sets.String.add v acc | _ -> acc) couplings Sets.String.empty in if not (Sets.String.is_empty ufo_couplings) then Printf.eprintf "SUMMARY: %d UFO vertices: %s\n" (Sets.String.cardinal ufo_couplings) (String.concat ", " (Sets.String.elements ufo_couplings)) end; if !poles then begin List.iter (fun amplitude -> W.write output_channel "omega" (W.merge (W.trees amplitude))) (CF.processes amplitudes) end; begin match !dag0_out with | Some name -> let ch = open_out name in List.iter (F.tower_to_dot ch) (CF.processes amplitudes); close_out ch | None -> () end; begin match !dag_out with | Some name -> let ch = open_out name in List.iter (F.amplitude_to_dot ch) (CF.processes amplitudes); close_out ch | None -> () end; begin match !phase_space_out with | Some name -> let ch = open_out name in begin try List.iter (fun (fin, fout) -> Printf.fprintf ch "%s -> %s ::\n" (String.concat " " (List.map M.flavor_to_string fin)) (String.concat " " (List.map M.flavor_to_string fout)); match fin with | [] -> failwith "Omega(): phase space: no incoming particles" | [f] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout) | [f1; f2] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout); PHS.phase_space_channels_flipped ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors [f2; f1] fout) | _ -> failwith "Omega(): phase space: 3 or more incoming particles") processes; close_out ch with | exc -> begin close_out ch; Printf.eprintf "O'Mega: exception %s in phase space construction!\n" (Printexc.to_string exc); flush stderr end end | None -> () end; if !print_forest then List.iter (fun amplitude -> List.iter (fun t -> Printf.eprintf "%s\n" (Tree.to_string (Tree.map (fun (wf, _) -> variable wf) (fun _ -> "") t))) (F.forest (List.hd (F.externals amplitude)) amplitude)) (CF.processes amplitudes); begin match !diagrams_all with | Some name -> amplitudes_to_feynmf !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_sans_color with | Some name -> amplitudes_to_feynmf_sans_color !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_color_only with | Some name -> amplitudes_to_feynmf_color_only !diagrams_LaTeX name amplitudes | None -> () end; begin match !output_file with | None -> () | Some name -> close_out output_channel end; exit 0 end (* \begin{dubious} This was only intended for debugging O'Giga \ldots \end{dubious} *) let decode wf = (F.flavor wf, (F.momentum wf : Momentum.Default.t)) let diagrams in1 in2 out = match F.amplitudes false F.no_exclusions C.no_cascades [in1; in2] out with | a :: _ -> let wf1 = List.hd (F.externals a) and wf2 = List.hd (List.tl (F.externals a)) in let wf2 = decode wf2 in List.map (fun t -> (wf2, Tree.map (fun (wf, _) -> decode wf) decode t)) (F.forest wf1 a) | [] -> [] let diagrams in1 in2 out = failwith "Omega().diagrams: disabled" end Index: trunk/omega/src/UFO.ml =================================================================== --- trunk/omega/src/UFO.ml (revision 8305) +++ trunk/omega/src/UFO.ml (revision 8306) @@ -1,2266 +1,2385 @@ (* UFO.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Unfortunately, \texttt{ocamlweb} will not typeset all multi character operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *) let (@@) f g x = f (g x) let (@@@) f g x y = f (g x y) +module SMap = Map.Make (struct type t = string let compare = compare end) +module SSet = Sets.String + +module CMap = + Map.Make + (struct + type t = string + let compare = ThoString.compare_caseless + end) +module CSet = Sets.String_Caseless + let error_in_string text start_pos end_pos = let i = start_pos.Lexing.pos_cnum and j = end_pos.Lexing.pos_cnum in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) let parse_string text = try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string text)) with + | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> + invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" + msg (error_in_string text start_pos end_pos)) | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let parse_file name = let ic = open_in name in let result = begin try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position name (Lexing.from_channel ic)) with + | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> + begin + close_in ic; + invalid_arg (Printf.sprintf + "%s: lexical error (%s)" + (error_in_file name start_pos end_pos) msg) + end | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: syntax error (%s)" (error_in_file name start_pos end_pos) msg) end | Parsing.Parse_error -> begin close_in ic; invalid_arg ("parse error: " ^ name) end end in close_in ic; result (* These are the contents of the Python files after lexical analysis as context-free variable declarations, before any semantic interpretation. *) module type Files = sig type t = private { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } val parse_directory : string -> t end module Files : Files = struct type t = { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } let parse_directory dir = let parse stem = parse_file (Filename.concat dir (stem ^ ".py")) in { particles = parse "particles"; couplings = parse "couplings"; coupling_orders = (try parse "coupling_orders" with _ -> []); vertices = parse "vertices"; lorentz = parse "lorentz"; parameters = parse "parameters"; propagators = (try parse "propagators" with _ -> []); decays = (try parse "decays" with _ -> []) } end let dump_file pfx f = List.iter (fun s -> print_endline (pfx ^ ": " ^ s)) (UFO_syntax.to_strings f) type charge = | Q_Integer of int | Q_Fraction of int * int let charge_to_string = function | Q_Integer i -> Printf.sprintf "%d" i | Q_Fraction (n, d) -> Printf.sprintf "%d/%d" n d module S = UFO_syntax let find_attrib name attribs = try (List.find (fun a -> name = a.S.a_name) attribs).S.a_value with | Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found") let find_attrib name attribs = (List.find (fun a -> name = a.S.a_name) attribs).S.a_value let name_to_string ?strip name = let stripped = begin match strip, List.rev name with | Some pfx, head :: tail -> if pfx = head then tail else failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^ "', got '" ^ head ^ "'") | _, name -> name end in String.concat "." stripped let name_attrib ?strip name attribs = match find_attrib name attribs with | S.Name n -> name_to_string ?strip n | _ -> invalid_arg name let integer_attrib name attribs = match find_attrib name attribs with | S.Integer i -> i | _ -> invalid_arg name let charge_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Q_Integer i | S.Fraction (n, d) -> Q_Fraction (n, d) | _ -> invalid_arg name let string_attrib name attribs = match find_attrib name attribs with | S.String s -> s | _ -> invalid_arg name let boolean_attrib name attribs = try - match String.lowercase (name_attrib name attribs) with + match ThoString.lowercase (name_attrib name attribs) with | "true" -> true | "false" -> false | _ -> invalid_arg name with | Not_found -> false type value = | Integer of int | Fraction of int * int | Float of float - | String of string + | Expr of UFOx.Expr.t | Name of string list +let map_expr f default = function + | Integer _ | Fraction (_, _) | Float _ | Name _ -> default + | Expr e -> f e + +let variables = map_expr UFOx.Expr.variables CSet.empty +let functions = map_expr UFOx.Expr.functions CSet.empty + +let add_to_set_in_map key element map = + let set = try CMap.find key map with Not_found -> CSet.empty in + CMap.add key (CSet.add element set) map + +(* Add all variables in [value] to the [map] from variables + to the names in which they appear, indicating + that [name] depends on these variables. *) +let dependency name value map = + CSet.fold + (fun variable acc -> add_to_set_in_map variable name acc) + (variables value) + map + +let dependencies name_value_list = + List.fold_left + (fun acc (name, value) -> dependency name value acc) + CMap.empty + name_value_list + +let dependency_to_string (variable, appearences) = + Printf.sprintf + "%s -> {%s}" + variable (String.concat ", " (CSet.elements appearences)) + +let dependencies_to_strings map = + List.map dependency_to_string (CMap.bindings map) + +let expr_to_string = + UFOx.Value.to_string @@ UFOx.Value.of_expr + let value_to_string = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x - | String s -> Printf.sprintf "'%s'" s + | Expr e -> "'" ^ expr_to_string e ^ "'" | Name n -> name_to_string n let value_to_expr substitutions = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%d/%d" n d | Float x -> string_of_float x - | String s -> - UFOx.Value.to_string - (UFOx.Value.of_expr (substitutions (UFOx.Expr.of_string s))) + | Expr e -> expr_to_string (substitutions e) | Name n -> name_to_string n let value_to_coupling substitutions atom = function | Integer i -> Coupling.Integer i | Fraction (n, d) -> Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Float x -> Coupling.Float x - | String s -> - UFOx.Value.to_coupling - atom (UFOx.Value.of_expr (substitutions (UFOx.Expr.of_string s))) + | Expr e -> + UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions e)) | Name n -> failwith "UFO.value_to_coupling: Name not supported yet!" let value_to_numeric = function | Integer i -> Printf.sprintf "%d" i | Fraction (n, d) -> Printf.sprintf "%g" (float n /. float d) | Float x -> Printf.sprintf "%g" x - | String s -> invalid_arg ("UFO.value_to_numeric: string = " ^ s) + | Expr e -> invalid_arg ("UFO.value_to_numeric: expr = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_numeric: name = " ^ name_to_string n) let value_to_float = function | Integer i -> float i | Fraction (n, d) -> float n /. float d | Float x -> x - | String s -> invalid_arg ("UFO.value_to_float: string = " ^ s) + | Expr e -> invalid_arg ("UFO.value_to_float: string = " ^ (expr_to_string e)) | Name n -> invalid_arg ("UFO.value_to_float: name = " ^ name_to_string n) let value_attrib name attribs = match find_attrib name attribs with | S.Integer i -> Integer i | S.Fraction (n, d) -> Fraction (n, d) | S.Float x -> Float x - | S.String s -> String s + | S.String s -> Expr (UFOx.Expr.of_string s) | S.Name n -> Name n | _ -> invalid_arg name let string_list_attrib name attribs = match find_attrib name attribs with | S.String_List l -> l | _ -> invalid_arg name let name_list_attrib ~strip name attribs = match find_attrib name attribs with | S.Name_List l -> List.map (name_to_string ~strip) l | _ -> invalid_arg name let integer_list_attrib name attribs = match find_attrib name attribs with | S.Integer_List l -> l | _ -> invalid_arg name let order_dictionary_attrib name attribs = match find_attrib name attribs with | S.Order_Dictionary d -> d | _ -> invalid_arg name let coupling_dictionary_attrib ~strip name attribs = match find_attrib name attribs with | S.Coupling_Dictionary d -> List.map (fun (i, j, c) -> (i, j, name_to_string ~strip c)) d | _ -> invalid_arg name let decay_dictionary_attrib name attribs = match find_attrib name attribs with | S.Decay_Dictionary d -> List.map (fun (p, w) -> (List.map List.hd p, w)) d | _ -> invalid_arg name -module SMap = Map.Make (struct type t = string let compare = compare end) - let map_to_alist map = SMap.fold (fun key value acc -> (key, value) :: acc) map [] let keys map = SMap.fold (fun key _ acc -> key :: acc) map [] +let keys_caseless map = + CMap.fold (fun key _ acc -> key :: acc) map [] + let values map = SMap.fold (fun _ value acc -> value :: acc) map [] module SKey = struct type t = string let hash = Hashtbl.hash let equal = (=) end module SHash = Hashtbl.Make (SKey) module type Particle = sig type t = private { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : int; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } val of_file : S.t -> t SMap.t val to_string : string -> t -> string val conjugate : t -> t val force_spinor : t -> t val force_conjspinor : t -> t val force_majorana : t -> t val is_majorana : t -> bool val is_ghost : t -> bool val is_goldstone : t -> bool val is_physical : t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Particle : Particle = struct type t = { pdg_code : int; name : string; antiname : string; spin : UFOx.Lorentz.r; color : UFOx.Color.r; mass : string; width : string; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : int; goldstone : bool; propagating : bool; (* NOT HANDLED YET! *) line : string option; (* NOT HANDLED YET! *) is_anti : bool } let to_string symbol p = Printf.sprintf "particle: %s => [pdg = %d, name = '%s'/'%s', \ spin = %s, color = %s, \ mass = %s, width = %s, \ Q = %s, G = %d, L = %d, Y = %d, \ TeX = '%s'/'%s'%s]" symbol p.pdg_code p.name p.antiname (UFOx.Lorentz.rep_to_string p.spin) (UFOx.Color.rep_to_string p.color) p.mass p.width (charge_to_string p.charge) p.ghost_number p.lepton_number p.y p.texname p.antitexname (if p.goldstone then ", GB" else "") let conjugate_charge = function | Q_Integer i -> Q_Integer (-i) | Q_Fraction (n, d) -> Q_Fraction (-n, d) let is_neutral p = (p.name = p.antiname) (* We \emph{must not} mess with [pdg_code] and [color] if the particle is neutral! *) let conjugate p = if is_neutral p then p else { pdg_code = - p.pdg_code; name = p.antiname; antiname = p.name; spin = UFOx.Lorentz.rep_conjugate p.spin; color = UFOx.Color.rep_conjugate p.color; mass = p.mass; width = p.width; texname = p.antitexname; antitexname = p.texname; charge = conjugate_charge p.charge; ghost_number = p.ghost_number; lepton_number = p.lepton_number; y = p.y; goldstone = p.goldstone; propagating = p.propagating; line = p.line; is_anti = not p.is_anti } let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Particle" ], attribs -> let name = string_attrib "name" attribs and antiname = string_attrib "antiname" attribs in let neutral = (name = antiname) in SMap.add symbol { pdg_code = integer_attrib "pdg_code" attribs; name; antiname; spin = UFOx.Lorentz.rep_of_int neutral (integer_attrib "spin" attribs); color = UFOx.Color.rep_of_int neutral (integer_attrib "color" attribs); mass = name_attrib ~strip:"Param" "mass" attribs; width = name_attrib ~strip:"Param" "width" attribs; texname = string_attrib "texname" attribs; antitexname = string_attrib "antitexname" attribs; charge = charge_attrib "charge" attribs; ghost_number = integer_attrib "GhostNumber" attribs; lepton_number = (try integer_attrib "LeptonNumber" attribs with _ -> 0); y = (try integer_attrib "Y" attribs with _ -> 0); goldstone = (try boolean_attrib "goldstone" attribs with _ -> false); propagating = true; line = None; is_anti = false} map | [ "anti"; p ], [] -> begin try SMap.add symbol (conjugate (SMap.find p map)) map with | Not_found -> invalid_arg ("Particle.of_file: " ^ p ^ ".anti() not yet defined!") end | _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind) let of_file particles = List.fold_left of_file1 SMap.empty particles let is_spinor p = match UFOx.Lorentz.omega p.spin with | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> true | _ -> false let force_spinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false 2 } else p let force_conjspinor p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int false (-2) } else p let force_majorana p = if is_spinor p then { p with spin = UFOx.Lorentz.rep_of_int true 2 } else p let is_majorana p = match UFOx.Lorentz.omega p.spin with | Coupling.Majorana -> true | _ -> false let is_ghost p = p.ghost_number <> 0 let is_goldstone p = p.goldstone let is_physical p = not (is_ghost p || is_goldstone p) let filter predicate map = SMap.filter (fun symbol p -> predicate p) map end module type UFO_Coupling = sig type t = private { name : string; - value : string; + value : UFOx.Expr.t; order : (string * int) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string - val to_string_expanded : string -> t -> string end module UFO_Coupling : UFO_Coupling = struct type t = { name : string; - value : string; + value : UFOx.Expr.t; order : (string * int) list } let order_to_string orders = String.concat ", " (List.map (fun (s, i) -> Printf.sprintf "'%s':%d" s i) orders) let to_string symbol c = Printf.sprintf "coupling: %s => [name = '%s', value = '%s', order = [%s]]" - symbol c.name c.value (order_to_string c.order) - - let to_string_expanded symbol c = - let expansion = - UFOx.Value.to_string (UFOx.Value.of_expr (UFOx.Expr.of_string c.value)) in - Printf.sprintf - "coupling: %s => [name = '%s', value = '%s', value' = '%s', order = [%s]]" - symbol c.name c.value expansion (order_to_string c.order) + symbol c.name (expr_to_string c.value) (order_to_string c.order) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Coupling" ], attribs -> let name = string_attrib "name" attribs in if name <> symbol then Printf.eprintf "UFO_Coupling.of_file: warning: symbol '%s' <> name '%s'\n" symbol name; SMap.add symbol { name = name; - value = string_attrib "value" attribs; + value = UFOx.Expr.of_string (string_attrib "value" attribs); order = order_dictionary_attrib "order" attribs } map | _ -> invalid_arg ("UFO_Coupling.of_file: " ^ name_to_string d.S.kind) let of_file couplings = List.fold_left of_file1 SMap.empty couplings end module type Coupling_Order = sig type t = private { name : string; expansion_order : int; hierarchy : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Coupling_Order : Coupling_Order = struct type t = { name : string; expansion_order : int; hierarchy : int } let to_string symbol c = Printf.sprintf "coupling_order: %s => [name = '%s', \ expansion_order = '%d', \ hierarchy = %d]" symbol c.name c.expansion_order c.hierarchy let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "CouplingOrder" ], attribs -> SMap.add symbol { name = string_attrib "name" attribs; expansion_order = integer_attrib "expansion_order" attribs; hierarchy = integer_attrib "hierarchy" attribs } map | _ -> invalid_arg ("Coupling_order.of_file: " ^ name_to_string d.S.kind) let of_file coupling_orders = List.fold_left of_file1 SMap.empty coupling_orders end module type Lorentz_UFO = sig type t = private { name : string; spins : int list; structure : UFOx.Lorentz.t } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Lorentz_UFO : Lorentz_UFO = struct type t = { name : string; spins : int list; structure : UFOx.Lorentz.t } let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = [%s], \ structure = %s]" symbol l.name (String.concat ", " (List.map string_of_int l.spins)) (UFOx.Lorentz.to_string l.structure) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Lorentz" ], attribs -> SMap.add symbol { name = string_attrib "name" attribs; spins = integer_list_attrib "spins" attribs; structure = UFOx.Lorentz.of_string (string_attrib "structure" attribs) } map | _ -> invalid_arg ("Lorentz.of_file: " ^ name_to_string d.S.kind) let of_file lorentz = List.fold_left of_file1 SMap.empty lorentz end module type Vertex = sig type lcc = private (* Lorentz-color-coupling *) { lorentz : string; color : UFOx.Color.t; coupling : string } type t = private { name : string; particles : string array; lcc : lcc list } val of_file : Particle.t SMap.t -> S.t -> t SMap.t val to_string : string -> t -> string val to_string_expanded : Lorentz_UFO.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string val contains : Particle.t SMap.t -> (Particle.t -> bool) -> t -> bool val filter : (t -> bool) -> t SMap.t -> t SMap.t end module Vertex : Vertex = struct type lcc = { lorentz : string; color : UFOx.Color.t; coupling : string } type t = { name : string; particles : string array; lcc : lcc list } let to_string symbol c = Printf.sprintf "vertex: %s => [name = '%s', particles = [%s], \ lorentz-color-couplings = [%s]" symbol c.name (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling lcc.lorentz (UFOx.Color.to_string lcc.color)) c.lcc)) let to_string_expanded lorentz couplings c = let expand_lorentz s = try UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure with | Not_found -> "?" in Printf.sprintf "expanded: [%s] -> { lorentz-color-couplings = [%s] }" (String.concat ", " (Array.to_list c.particles)) (String.concat ", " (List.map (fun lcc -> Printf.sprintf "%s * %s * %s" lcc.coupling (expand_lorentz lcc.lorentz) (UFOx.Color.to_string lcc.color)) c.lcc)) let contains particles predicate v = let p = v.particles in let rec contains' i = if i < 0 then false else if predicate (SMap.find p.(i) particles) then true else contains' (pred i) in contains' (Array.length p - 1) let force_adj_identity1 adj_indices = function | UFOx.Color_Atom.Identity (a, b) as atom -> begin match List.mem a adj_indices, List.mem b adj_indices with | true, true -> UFOx.Color_Atom.Identity8 (a, b) | false, false -> atom | true, false | false, true -> invalid_arg "force_adj_identity: mixed representations!" end | atom -> atom let force_adj_identity adj_indices tensor = UFOx.Color.map_atoms (force_adj_identity1 adj_indices) tensor let find_adj_indices map particles = let adj_indices = ref [] in Array.iteri (fun i p -> (* We must pattern match against the O'Mega representation, because [UFOx.Color.r] is abstract. *) match UFOx.Color.omega (SMap.find p map).Particle.color with | Color.AdjSUN _ -> adj_indices := succ i :: !adj_indices | _ -> ()) particles; !adj_indices let classify_color_indices map particles = let fund_indices = ref [] and conj_indices = ref [] and adj_indices = ref [] in Array.iteri (fun i p -> (* We must pattern match against the O'Mega representation, because [UFOx.Color.r] is abstract. *) match UFOx.Color.omega (SMap.find p map).Particle.color with | Color.SUN n -> if n > 0 then fund_indices := succ i :: !fund_indices else if n < 0 then conj_indices := succ i :: !conj_indices else failwith "classify_color_indices: SU(0)" | Color.AdjSUN n -> if n <> 0 then adj_indices := succ i :: !adj_indices else failwith "classify_color_indices: SU(0)" | _ -> ()) particles; (!fund_indices, !conj_indices, !adj_indices) (* FIXME: would have expected the opposite order \ldots *) let force_identity1 (fund_indices, conj_indices, adj_indices) = function | UFOx.Color_Atom.Identity (a, b) as atom -> if List.mem a fund_indices then begin if List.mem b conj_indices then UFOx.Color_Atom.Identity (b, a) else invalid_arg "force_adj_identity: mixed representations!" end else if List.mem a conj_indices then begin if List.mem b fund_indices then UFOx.Color_Atom.Identity (a, b) else invalid_arg "force_adj_identity: mixed representations!" end else if List.mem a adj_indices then begin if List.mem b adj_indices then UFOx.Color_Atom.Identity8 (a, b) else invalid_arg "force_adj_identity: mixed representations!" end else atom | atom -> atom let force_identity indices tensor = UFOx.Color.map_atoms (force_identity1 indices) tensor (* Here we don't have the Lorentz structures available yet. Thus we set [fermion_lines = []] for now and correct this later. *) let of_file1 particle_map map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Vertex" ], attribs -> let particles = Array.of_list (name_list_attrib ~strip:"P" "particles" attribs) in let color = let indices = classify_color_indices particle_map particles in Array.of_list (List.map (force_identity indices @@ UFOx.Color.of_string) (string_list_attrib "color" attribs)) and lorentz = Array.of_list (name_list_attrib ~strip:"L" "lorentz" attribs) and couplings_alist = coupling_dictionary_attrib ~strip:"C" "couplings" attribs in let lcc = List.map (fun (i, j, c) -> { lorentz = lorentz.(j); color = color.(i); coupling = c }) couplings_alist in SMap.add symbol { name = string_attrib "name" attribs; particles; lcc } map | _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind) let of_file particles vertices = List.fold_left (of_file1 particles) SMap.empty vertices let filter predicate map = SMap.filter (fun symbol p -> predicate p) map end module type Parameter = sig type nature = private Internal | External type ptype = private Real | Complex type t = private { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } val of_file : S.t -> t SMap.t val to_string : string -> t -> string + val missing : string -> t + end module Parameter : Parameter = struct type nature = Internal | External let nature_to_string = function | Internal -> "internal" | External -> "external" let nature_of_string = function | "internal" -> Internal | "external" -> External | s -> invalid_arg ("Parameter.nature_of_string: " ^ s) type ptype = Real | Complex let ptype_to_string = function | Real -> "real" | Complex -> "complex" let ptype_of_string = function | "real" -> Real | "complex" -> Complex | s -> invalid_arg ("Parameter.ptype_of_string: " ^ s) type t = { name : string; nature : nature; ptype : ptype; value : value; texname : string; lhablock : string option; lhacode : int list option; sequence : int } let to_string symbol p = Printf.sprintf "parameter: %s => [#%d, name = '%s', nature = %s, type = %s, \ value = %s, texname = '%s', \ lhablock = %s, lhacode = [%s]]" symbol p.sequence p.name (nature_to_string p.nature) (ptype_to_string p.ptype) (value_to_string p.value) p.texname (match p.lhablock with None -> "???" | Some s -> s) (match p.lhacode with | None -> "" | Some c -> String.concat ", " (List.map string_of_int c)) let of_file1 (map, n) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Parameter" ], attribs -> (SMap.add symbol { name = string_attrib "name" attribs; nature = nature_of_string (string_attrib "nature" attribs); ptype = ptype_of_string (string_attrib "type" attribs); value = value_attrib "value" attribs; texname = string_attrib "texname" attribs; lhablock = (try Some (string_attrib "lhablock" attribs) with Not_found -> None); lhacode = (try Some (integer_list_attrib "lhacode" attribs) with Not_found -> None); sequence = n } map, succ n) | _ -> invalid_arg ("Parameter.of_file: " ^ name_to_string d.S.kind) let of_file parameters = let map, _ = List.fold_left of_file1 (SMap.empty, 0) parameters in map + let missing name = + { name; + nature = External; + ptype = Real; + value = Integer 0; + texname = Printf.sprintf "\\texttt{%s}" name; + lhablock = None; + lhacode = None; + sequence = 0 } + end module type Propagator = sig type t = private { name : string; numerator : string; denominator : string } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Propagator : Propagator = struct type t = { name : string; numerator : string; denominator : string } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', numerator = '%s', \ denominator = '%s']" symbol p.name p.numerator p.denominator (* The parser will turn [foo = "bar"] into [foo = "bar"."$"], which will be interpreted as a macro definition for [foo] expanding to ["bar"]. The dollar is used to distinguish it from an empty attribute list. This could also be implemented with a union type for the declarations. *) let of_file1 (macros, map) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Propagator" ], attribs -> let denominator = begin match find_attrib "denominator" attribs with | S.String s -> s | S.Name [n] -> SMap.find n macros | _ -> invalid_arg "Propagator.denominator: " end in (macros, SMap.add symbol { name = string_attrib "name" attribs; numerator = string_attrib "numerator" attribs; denominator = denominator } map) | [ "$"; s ], [] -> (SMap.add symbol s macros, map) | _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind) let of_file propagators = let _, propagators' = List.fold_left of_file1 (SMap.empty, SMap.empty) propagators in propagators' end module type Decay = sig type t = private { name : string; particle : string; widths : (string list * string) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Decay : Decay = struct type t = { name : string; particle : string; widths : (string list * string) list } let width_to_string ws = String.concat ", " (List.map (fun (ps, w) -> "(" ^ String.concat ", " ps ^ ") -> '" ^ w ^ "'") ws) let to_string symbol d = Printf.sprintf "decay: %s => [name = '%s', particle = '%s', widths = [%s]]" symbol d.name d.particle (width_to_string d.widths) let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Decay" ], attribs -> SMap.add symbol { name = string_attrib "name" attribs; particle = name_attrib ~strip:"P" "particle" attribs; widths = decay_dictionary_attrib "partial_widths" attribs } map | _ -> invalid_arg ("Decay.of_file: " ^ name_to_string d.S.kind) let of_file decays = List.fold_left of_file1 SMap.empty decays end (* We can read the spinor representations off the vertices to check for consistency. *) (* \begin{dubious} Note that we have to conjugate the representations! \end{dubious} *) let collect_spinor_reps_of_vertex particles lorentz v sets = List.fold_left (fun sets' lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in List.fold_left (fun (spinors, conj_spinors as sets'') (i, rep) -> let p = v.Vertex.particles.(pred i) in match UFOx.Lorentz.omega rep with - | Coupling.ConjSpinor -> (Sets.String.add p spinors, conj_spinors) - | Coupling.Spinor -> (spinors, Sets.String.add p conj_spinors) + | Coupling.ConjSpinor -> (SSet.add p spinors, conj_spinors) + | Coupling.Spinor -> (spinors, SSet.add p conj_spinors) | _ -> sets'') sets' (UFOx.Lorentz.classify_indices l)) sets v.Vertex.lcc let collect_spinor_reps_of_vertices particles lorentz vertices = SMap.fold (fun _ v -> collect_spinor_reps_of_vertex particles lorentz v) - vertices (Sets.String.empty, Sets.String.empty) + vertices (SSet.empty, SSet.empty) let lorentz_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not @@ UFOx.Lorentz.rep_trivial) ~offset:1 (List.map (fun p -> (* Why do we need to conjugate??? *) UFOx.Lorentz.rep_conjugate (SMap.find p particles).Particle.spin) (Array.to_list v.Vertex.particles)) let rep_compatible rep_vertex rep_particle = let open UFOx.Lorentz in let open Coupling in match omega rep_vertex, omega rep_particle with | (Spinor | ConjSpinor), Majorana -> true | r1, r2 -> r1 = r2 let reps_compatible reps_vertex reps_particles = List.for_all2 (fun (iv, rv) (ip, rp) -> iv = ip && rep_compatible rv rp) reps_vertex reps_particles let check_lorentz_reps_of_vertex particles lorentz v = let reps_particles = List.sort compare (lorentz_reps_of_vertex particles v) in List.iter (fun lcc -> let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in let reps_vertex = List.sort compare (UFOx.Lorentz.classify_indices l) in if not (reps_compatible reps_vertex reps_particles) then begin Printf.eprintf "%s <> %s [%s]\n" (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string reps_vertex) v.Vertex.name (* [(Vertex.to_string v.Vertex.name v)] *); (* [invalid_arg "check_lorentz_reps_of_vertex"] *) () end) v.Vertex.lcc let color_reps_of_vertex particles v = ThoList.alist_of_list ~predicate:(not @@ UFOx.Color.rep_trivial) ~offset:1 (List.map (fun p -> (SMap.find p particles).Particle.color) (Array.to_list v.Vertex.particles)) let check_color_reps_of_vertex particles v = let reps_particles = List.sort compare (color_reps_of_vertex particles v) in List.iter (fun lcc -> let reps_vertex = List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in if reps_vertex <> reps_particles then begin Printf.printf "%s <> %s\n" (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex); invalid_arg "check_color_reps_of_vertex" end) v.Vertex.lcc module P = Permutation.Default module type Lorentz = sig type spins = private | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t type t = private { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines } val permute : P.t -> t -> t val of_lorentz_UFO : Particle.t SMap.t -> Vertex.t SMap.t -> Lorentz_UFO.t SMap.t -> t SMap.t val to_string : string -> t -> string end module Lorentz : Lorentz = struct let rec lorentz_to_string = function | Coupling.Scalar -> "Scalar" | Coupling.Spinor -> "Spinor" | Coupling.ConjSpinor -> "ConjSpinor" | Coupling.Majorana -> "Majorana" | Coupling.Maj_Ghost -> "Maj_Ghost" | Coupling.Vector -> "Vector" | Coupling.Massive_Vector -> "Massive_Vector" | Coupling.Vectorspinor -> "Vectorspinor" | Coupling.Tensor_1 -> "Tensor_1" | Coupling.Tensor_2 -> "Tensor_2" | Coupling.BRS l -> "BRS(" ^ lorentz_to_string l ^ ")" (* Unlike UFO, O'Mega distinguishes bewteen spinors and conjugate spinors. However, we can inspect the particles in the vertices in which a Lorentz structure is used to determine the correct quantum numbers. Most model files in the real world contain unused Lorentz structures. This is not a problem, we can just ignore them. *) type spins = | Unused | Unique of Coupling.lorentz array | Ambiguous of Coupling.lorentz array SMap.t type t = { name : string; n : int; spins : spins; structure : UFO_Lorentz.t; fermion_lines : Coupling.fermion_lines } let permute_spins p = function | Unused -> Unused | Unique s -> Unique (P.array p s) | Ambiguous map -> Ambiguous (SMap.map (P.array p) map) (* Note that we apply the \emph{inverse} permutation to the indices in order to match the permutation of the particles/spins. *) let permute_structure n p (l, f) = let permuted = P.array (P.inverse p) (Array.init n succ) in let permute_index i = if i > 0 then permuted.(pred i) else i in (UFO_Lorentz.map_indices permute_index l, UFO_Lorentz.map_fermion_lines permute_index f) let permute p l = let structure, fermion_lines = permute_structure l.n p (l.structure, l.fermion_lines) in { name = l.name ^ "_p" ^ P.to_string (P.inverse p); n = l.n; spins = permute_spins p l.spins; structure; fermion_lines } let omega_lorentz_reps n alist = let reps = Array.make n Coupling.Scalar in List.iter (fun (i, rep) -> reps.(pred i) <- UFOx.Lorentz.omega rep) alist; reps let contained lorentz vertex = List.exists (fun lcc1 -> lcc1.Vertex.lorentz = lorentz.Lorentz_UFO.name) vertex.Vertex.lcc (* Find all vertices in with the Lorentz structure [lorentz] is used and build a map from those vertices to the O'Mega Lorentz representations inferred from UFO's Lorentz structure and the [particles] involved. Then scan the bindings and check that we have inferred the same Lorentz representation from all vertices. *) let lorentz_reps_of_structure particles vertices lorentz = let uses = SMap.fold (fun name v acc -> if contained lorentz v then SMap.add name (omega_lorentz_reps (Array.length v.Vertex.particles) (lorentz_reps_of_vertex particles v)) acc else acc) vertices SMap.empty in let variants = ThoList.uniq (List.sort compare (List.map snd (SMap.bindings uses))) in match variants with | [] -> Unused | [s] -> Unique s | _ -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: AMBIGUOUS!\n"; List.iter (fun variant -> Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: %s\n" (ThoList.to_string lorentz_to_string (Array.to_list variant))) variants; Ambiguous uses let of_lorentz_tensor spins lorentz = match spins with | Unique s -> begin try Some (UFO_Lorentz.parse (Array.to_list s) lorentz) with | Failure msg -> begin prerr_endline msg; Some (UFO_Lorentz.dummy) end end | Unused -> Printf.eprintf "UFO.Lorentz: stripping unused structure %s\n" (UFOx.Lorentz.to_string lorentz); None | Ambiguous _ -> invalid_arg "UFO.Lorentz.of_lorentz_tensor: Ambiguous" let of_lorentz_UFO particles vertices lorentz_UFO = SMap.fold (fun name l acc -> let spins = lorentz_reps_of_structure particles vertices l in match of_lorentz_tensor spins l.Lorentz_UFO.structure with | None -> acc | Some structure -> SMap.add name { name = l.Lorentz_UFO.name; n = List.length l.Lorentz_UFO.spins; spins; structure; fermion_lines = UFO_Lorentz.fermion_lines structure } acc) lorentz_UFO SMap.empty let to_string symbol l = Printf.sprintf "lorentz: %s => [name = '%s', spins = %s, \ structure = %s, fermion_lines = %s]" symbol l.name (match l.spins with | Unique s -> "[" ^ String.concat ", " (List.map lorentz_to_string (Array.to_list s)) ^ "]" | Ambiguous _ -> "AMBIGUOUS!" | Unused -> "UNUSED!") (UFO_Lorentz.to_string l.structure) (UFO_Lorentz.fermion_lines_to_string l.fermion_lines) end type t = { particles : Particle.t SMap.t; particle_array : Particle.t array; (* for diagnostics *) couplings : UFO_Coupling.t SMap.t; coupling_orders : Coupling_Order.t SMap.t; vertices : Vertex.t SMap.t; lorentz_UFO : Lorentz_UFO.t SMap.t; lorentz : Lorentz.t SMap.t; parameters : Parameter.t SMap.t; propagators : Propagator.t SMap.t; decays : Decay.t SMap.t; nc : int } let use_majorana_spinors = ref false let fallback_to_majorana_if_necessary particles vertices lorentz_UFO = let majoranas = SMap.fold (fun p particle acc -> if Particle.is_majorana particle then - Sets.String.add p acc + SSet.add p acc else acc) - particles Sets.String.empty in + particles SSet.empty in let spinors, conj_spinors = collect_spinor_reps_of_vertices particles lorentz_UFO vertices in let ambiguous = - Sets.String.diff (Sets.String.inter spinors conj_spinors) majoranas in - let no_majoranas = Sets.String.is_empty majoranas - and no_ambiguities = Sets.String.is_empty ambiguous in + SSet.diff (SSet.inter spinors conj_spinors) majoranas in + let no_majoranas = SSet.is_empty majoranas + and no_ambiguities = SSet.is_empty ambiguous in if no_majoranas && no_ambiguities && not !use_majorana_spinors then SMap.mapi (fun p particle -> - if Sets.String.mem p spinors then + if SSet.mem p spinors then Particle.force_spinor particle - else if Sets.String.mem p conj_spinors then + else if SSet.mem p conj_spinors then Particle.force_conjspinor particle else particle) particles else begin if !use_majorana_spinors then Printf.eprintf "O'Mega: Majorana fermions requested.\n"; if not no_majoranas then Printf.eprintf "O'Mega: found Majorana fermions!\n"; if not no_ambiguities then Printf.eprintf "O'Mega: found ambiguous spinor representations for %s!\n" - (String.concat ", " (Sets.String.elements ambiguous)); + (String.concat ", " (SSet.elements ambiguous)); Printf.eprintf "O'Mega: falling back to the Majorana representation for all fermions.\n"; SMap.map Particle.force_majorana particles end let nc_of_particles particles = let nc_set = List.fold_left (fun nc_set (_, p) -> match UFOx.Color.omega p.Particle.color with | Color.Singlet -> nc_set | Color.SUN nc -> Sets.Int.add (abs nc) nc_set | Color.AdjSUN nc -> Sets.Int.add (abs nc) nc_set) Sets.Int.empty (SMap.bindings particles) in match Sets.Int.elements nc_set with | [] -> 0 | [n] -> n | nc_list -> invalid_arg ("UFO.Model: more than one value of N_C: " ^ String.concat ", " (List.map string_of_int nc_list)) let of_file u = let particles = Particle.of_file u.Files.particles in let vertices = Vertex.of_file particles u.Files.vertices and lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz in let particles = fallback_to_majorana_if_necessary particles vertices lorentz_UFO in let particle_array = Array.of_list (values particles) and lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO in let model = { particles; particle_array; couplings = UFO_Coupling.of_file u.Files.couplings; coupling_orders = Coupling_Order.of_file u.Files.coupling_orders; vertices; lorentz_UFO; lorentz; parameters = Parameter.of_file u.Files.parameters; propagators = Propagator.of_file u.Files.propagators; decays = Decay.of_file u.Files.decays; nc = nc_of_particles particles } in SMap.iter (fun _ v -> check_color_reps_of_vertex model.particles v; check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v) model.vertices; model let parse_directory dir = of_file (Files.parse_directory dir) let dump model = Printf.printf "NC = %d\n" model.nc; SMap.iter (print_endline @@@ Particle.to_string) model.particles; - SMap.iter (print_endline @@@ UFO_Coupling.to_string_expanded) model.couplings; + SMap.iter (print_endline @@@ UFO_Coupling.to_string) model.couplings; SMap.iter (print_endline @@@ Coupling_Order.to_string) model.coupling_orders; (* [SMap.iter (print_endline @@@ Vertex.to_string) model.vertices;] *) SMap.iter (fun symbol v -> (print_endline @@@ Vertex.to_string) symbol v; print_endline (Vertex.to_string_expanded model.lorentz_UFO model.couplings v); check_color_reps_of_vertex model.particles v; check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v) model.vertices; SMap.iter (print_endline @@@ Lorentz_UFO.to_string) model.lorentz_UFO; SMap.iter (print_endline @@@ Lorentz.to_string) model.lorentz; SMap.iter (print_endline @@@ Parameter.to_string) model.parameters; SMap.iter (print_endline @@@ Propagator.to_string) model.propagators; SMap.iter (print_endline @@@ Decay.to_string) model.decays; SMap.iter (fun symbol d -> List.iter (fun (_, w) -> ignore (UFOx.Expr.of_string w)) d.Decay.widths) model.decays exception Unhandled of string let unhandled s = raise (Unhandled s) module Model = struct (* NB: we could use [type flavor = Particle.t], but that would be very inefficient, because we will use [flavor] as a key for maps below. *) type flavor = int type constant = string type gauge = unit module M = Modeltools.Mutable (struct type f = flavor type g = gauge type c = constant end) let flavors = M.flavors let external_flavors = M.external_flavors let external_flavors = M.external_flavors let lorentz = M.lorentz let color = M.color let nc = M.nc let propagator = M.propagator let width = M.width let goldstone = M.goldstone let conjugate = M.conjugate let fermion = M.fermion let vertices = M.vertices let fuse2 = M.fuse2 let fuse3 = M.fuse3 let fuse = M.fuse let max_degree = M.max_degree let parameters = M.parameters let flavor_of_string = M.flavor_of_string let flavor_to_string = M.flavor_to_string let flavor_to_TeX = M.flavor_to_TeX let flavor_symbol = M.flavor_symbol let gauge_symbol = M.gauge_symbol let pdg = M.pdg let mass_symbol = M.mass_symbol let width_symbol = M.width_symbol let constant_symbol = M.constant_symbol module Ch = M.Ch let charges = M.charges let rec fermion_of_lorentz = function | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> -1 | Coupling.Majorana -> 2 | Coupling.Maj_Ghost -> 2 | Coupling.Vectorspinor -> 1 | Coupling.Vector | Coupling.Massive_Vector -> 0 | Coupling.Scalar | Coupling.Tensor_1 | Coupling.Tensor_2 -> 0 | Coupling.BRS f -> fermion_of_lorentz f module Q = Algebra.Q module QC = Algebra.QC let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1 let dummy_tensor4 = Coupling.Scalar4 1 let triplet p = (p.(0), p.(1), p.(2)) let quartet p = (p.(0), p.(1), p.(2), p.(3)) let half_times q1 q2 = Q.mul (Q.make 1 2) (Q.mul q1 q2) let name g = g.UFO_Coupling.name let fractional_coupling g r = let g = name g in match Q.to_ratio r with | 0, _ -> "0.0_default" | 1, 1 -> g | -1, 1 -> Printf.sprintf "(-%s)" g | n, 1 -> Printf.sprintf "(%d*%s)" n g | 1, d -> Printf.sprintf "(%s/%d)" g d | -1, d -> Printf.sprintf "(-%s/%d)" g d | n, d -> Printf.sprintf "(%d*%s/%d)" n g d let lorentz_of_symbol model symbol = try SMap.find symbol model.lorentz with | Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol) let lorentz_UFO_of_symbol model symbol = try SMap.find symbol model.lorentz_UFO with | Not_found -> invalid_arg ("lorentz_UFO_of_symbol: " ^ symbol) let coupling_of_symbol model symbol = try SMap.find symbol model.couplings with | Not_found -> invalid_arg ("coupling_of_symbol: " ^ symbol) let spin_triplet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique [|s0; s1; s2|] -> (s0, s1, s2) | Lorentz.Unique _ -> invalid_arg "spin_triplet: wrong number of spins" | Lorentz.Unused -> invalid_arg "spin_triplet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_triplet: Ambiguous" let spin_quartet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique [|s0; s1; s2; s3|] -> (s0, s1, s2, s3) | Lorentz.Unique _ -> invalid_arg "spin_quartet: wrong number of spins" | Lorentz.Unused -> invalid_arg "spin_quartet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_quartet: Ambiguous" let spin_multiplet model name = match (lorentz_of_symbol model name).Lorentz.spins with | Lorentz.Unique sarray -> sarray | Lorentz.Unused -> invalid_arg "spin_multiplet: Unused" | Lorentz.Ambiguous _ -> invalid_arg "spin_multiplet: Ambiguous" (* If we have reason to belive that a $\delta_{ab}$-vertex is an effective $\tr(T_aT_b)$-vertex generated at loop level, like~$gg\to H\ldots$ in the SM, we should interpret it as such and use the expression~(6.2) from~\cite{Kilian:2012pz}. *) (* AFAIK, there is no way to distinguish these cases directly in a UFO file. Instead we rely in a heuristic, in which each massless color octet vector particle or ghost is a gluon and colorless scalars are potential Higgses. *) let is_massless p = - match String.uppercase p.Particle.mass with + match ThoString.uppercase p.Particle.mass with | "ZERO" -> true | _ -> false let is_gluon model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color, UFOx.Lorentz.omega p.Particle.spin with | Color.AdjSUN _, Coupling.Vector -> is_massless p | Color.AdjSUN _, Coupling.Scalar -> if p.Particle.ghost_number <> 0 then is_massless p else false | _ -> false let is_color_singlet model f = let p = model.particle_array.(f) in match UFOx.Color.omega p.Particle.color with | Color.Singlet -> true | _ -> false let is_higgs_gluon_vertex model p adjoints = if Array.length p > List.length adjoints then List.for_all (fun (i, p) -> if List.mem i adjoints then is_gluon model p else is_color_singlet model p) (ThoList.enumerate 1 (Array.to_list p)) else false let delta8_heuristics model p a b = if is_higgs_gluon_vertex model p [a; b] then Color.Vertex.delta8_loop a b else Color.Vertex.delta8 a b let verbatim_higgs_glue = ref false let translate_color_atom model p = function | UFOx.Color_Atom.Identity (i, j) -> Color.Vertex.delta3 i j | UFOx.Color_Atom.Identity8 (a, b) -> if !verbatim_higgs_glue then Color.Vertex.delta8 a b else delta8_heuristics model p a b | UFOx.Color_Atom.T (a, i, j) -> Color.Vertex.t a i j | UFOx.Color_Atom.F (a, b, c) -> Color.Vertex.f a b c | UFOx.Color_Atom.D (a, b, c) -> Color.Vertex.d a b c | UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon i j k | UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilonbar i j k | UFOx.Color_Atom.T6 (a, i, j) -> Color.Vertex.t6 a i j | UFOx.Color_Atom.K6 (i, j, k) -> Color.Vertex.k6 i j k | UFOx.Color_Atom.K6Bar (i, j, k) -> Color.Vertex.k6bar i j k let translate_color_term model p = function | [], q -> Color.Vertex.scale q Color.Vertex.unit | [atom], q -> Color.Vertex.scale q (translate_color_atom model p atom) | atoms, q -> let atoms = List.map (translate_color_atom model p) atoms in Color.Vertex.scale q (Color.Vertex.multiply atoms) let translate_color model p terms = match terms with | [] -> invalid_arg "translate_color: empty" | [ term ] -> translate_color_term model p term | terms -> Color.Vertex.sum (List.map (translate_color_term model p) terms) let translate_coupling_1 model p lcc = let l = lcc.Vertex.lorentz in let s = Array.to_list (spin_multiplet model l) and fl = (SMap.find l model.lorentz).Lorentz.fermion_lines and c = name (coupling_of_symbol model lcc.Vertex.coupling) and col = translate_color model p lcc.Vertex.color in (Array.to_list p, Coupling.UFO (QC.one, l, s, fl, col), c) let translate_coupling model p lcc = List.map (translate_coupling_1 model p) lcc let long_flavors = ref false module type Lookup = sig type f = private { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal val flavor_format : flavor_format ref val of_model : t -> f end module Lookup : Lookup = struct type f = { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal let flavor_format = ref Hexadecimal let conjugate_of_particle_array particles = Array.init (Array.length particles) (fun i -> let f' = Particle.conjugate particles.(i) in match ThoArray.match_all f' particles with | [i'] -> i' | [] -> invalid_arg ("no charge conjugate: " ^ f'.Particle.name) | _ -> invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name)) let invert_flavor_array a = let table = SHash.create 37 in Array.iteri (fun i s -> SHash.add table s i) a; (fun name -> try SHash.find table name with | Not_found -> invalid_arg ("not found: " ^ name)) let digits base n = let rec digits' acc n = if n < 1 then acc else digits' (succ acc) (n / base) in if n < 0 then digits' 1 (-n) else if n = 0 then 1 else digits' 0 n let of_model model = let particle_array = Array.of_list (values model.particles) in let conjugate_array = conjugate_of_particle_array particle_array and name_array = Array.map (fun f -> f.Particle.name) particle_array and symbol_array = Array.of_list (keys model.particles) in let flavor_symbol f = begin match !flavor_format with | Long -> symbol_array.(f) | Decimal -> let w = digits 10 (Array.length particle_array - 1) in Printf.sprintf "%0*d" w f | Hexadecimal -> let w = digits 16 (Array.length particle_array - 1) in Printf.sprintf "%0*X" w f end in { flavors = ThoList.range 0 (Array.length particle_array - 1); flavor_of_string = invert_flavor_array name_array; flavor_of_symbol = invert_flavor_array symbol_array; particle = Array.get particle_array; flavor_symbol = flavor_symbol; conjugate = Array.get conjugate_array } end (* \begin{dubious} We appear to need to conjugate all flavors. Why??? \end{dubious} *) let translate_vertices model tables = let vn = List.fold_left (fun acc v -> let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles and lcc = v.Vertex.lcc in let p = Array.map conjugate p in (* FIXME: why? *) translate_coupling model p lcc @ acc) [] (values model.vertices) in ([], [], vn) let propagator_of_lorentz = function | Coupling.Scalar -> Coupling.Prop_Scalar | Coupling.Spinor -> Coupling.Prop_Spinor | Coupling.ConjSpinor -> Coupling.Prop_ConjSpinor | Coupling.Majorana -> Coupling.Prop_Majorana | Coupling.Maj_Ghost -> invalid_arg "UFO.Model.propagator_of_lorentz: SUSY ghosts do not propagate" | Coupling.Vector -> Coupling.Prop_Feynman | Coupling.Massive_Vector -> Coupling.Prop_Unitarity | Coupling.Vectorspinor -> invalid_arg "UFO.Model.propagator_of_lorentz: Vectorspinor" | Coupling.Tensor_1 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_1" | Coupling.Tensor_2 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_2" | Coupling.BRS _ -> invalid_arg "UFO.Model.propagator_of_lorentz: no BRST" let filter_unphysical model = let physical_particles = Particle.filter Particle.is_physical model.particles in let physical_particle_array = Array.of_list (values physical_particles) in let physical_vertices = Vertex.filter (not @@ (Vertex.contains model.particles (not @@ Particle.is_physical))) model.vertices in { model with particles = physical_particles; particle_array = physical_particle_array; vertices = physical_vertices } let whizard_constants = - [ "ZERO" ] + SSet.of_list + [ "ZERO" ] let filter_constants parameters = List.filter (fun p -> - not (List.mem (String.uppercase p.Parameter.name) whizard_constants)) + not (SSet.mem (ThoString.uppercase p.Parameter.name) whizard_constants)) parameters + let add_name set parameter = + CSet.add parameter.Parameter.name set + + let hardcoded_parameters = + CSet.of_list + ["cmath.pi"] + + let missing_parameters input derived couplings = + let input_parameters = + List.fold_left add_name hardcoded_parameters input in + let all_parameters = + List.fold_left add_name input_parameters derived in + let derived_dependencies = + dependencies + (List.map + (fun p -> (p.Parameter.name, p.Parameter.value)) + derived) in + let coupling_dependencies = + dependencies + (List.map + (fun p -> (p.UFO_Coupling.name, Expr p.UFO_Coupling.value)) + (values couplings)) in + let missing_input = + CMap.filter + (fun parameter derived_parameters -> + not (CSet.mem parameter all_parameters)) + derived_dependencies + and missing = + CMap.filter + (fun parameter couplings -> + not (CSet.mem parameter all_parameters)) + coupling_dependencies in + CMap.iter + (fun parameter derived_parameters -> + Printf.eprintf + "UFO warning: undefined input parameter %s appears in derived \ + parameters {%s}: will be added to the list of input parameters!\n" + parameter (String.concat "; " (CSet.elements derived_parameters))) + missing_input; + CMap.iter + (fun parameter couplings -> + Printf.eprintf + "UFO warning: undefined parameter %s appears in couplings {%s}: \ + will be added to the list of input parameters!\n" + parameter (String.concat "; " (CSet.elements couplings))) + missing; + keys_caseless missing_input @ keys_caseless missing + let classify_parameters model = let compare_parameters p1 p2 = compare p1.Parameter.sequence p2.Parameter.sequence in let input, derived = List.fold_left (fun (input, derived) p -> match p.Parameter.nature with | Parameter.Internal -> (input, p :: derived) | Parameter.External -> begin match p.Parameter.ptype with | Parameter.Real -> () | Parameter.Complex -> Printf.eprintf "UFO warning: invalid complex declaration of input \ parameter `%s' ignored!\n" p.Parameter.name end; (p :: input, derived)) ([], []) (filter_constants (values model.parameters)) in - (List.sort compare_parameters input, + let additional = missing_parameters input derived model.couplings in + (List.sort compare_parameters input @ List.map Parameter.missing additional, List.sort compare_parameters derived) +(*i + List.iter + (fun line -> Printf.eprintf "par: %s\n" line) + (dependencies_to_strings derived_dependencies); + List.iter + (fun line -> Printf.eprintf "coupling: %s\n" line) + (dependencies_to_strings coupling_dependencies); +i*) + let translate_name map name = try SMap.find name map with Not_found -> name let translate_input map p = (translate_name map p.Parameter.name, value_to_float p.Parameter.value) let alpha_s_half e = UFOx.Expr.substitute "aS" (UFOx.Expr.half "aS") e let alpha_s_half_etc map e = UFOx.Expr.rename (map_to_alist map) (alpha_s_half e) let translate_derived map p = let make_atom s = s in let c = make_atom (translate_name map p.Parameter.name) and v = value_to_coupling (alpha_s_half_etc map) make_atom p.Parameter.value in match p.Parameter.ptype with | Parameter.Real -> (Coupling.Real c, v) | Parameter.Complex -> (Coupling.Complex c, v) let translate_coupling_constant map c = let make_atom s = s in (Coupling.Complex c.UFO_Coupling.name, Coupling.Quot (value_to_coupling (alpha_s_half_etc map) make_atom - (String c.UFO_Coupling.value), + (Expr c.UFO_Coupling.value), Coupling.I)) module LCP = struct type elt = string type base = string let compare_elt = compare let compare_base = compare - let pi = String.lowercase + let pi = ThoString.lowercase end module LCB = Bundle.Make (LCP) let coupling_names model = SMap.fold (fun _ c acc -> c.UFO_Coupling.name :: acc) model.couplings [] let parameter_names model = SMap.fold (fun _ c acc -> c.Parameter.name :: acc) model.parameters [] let ambiguous_parameters model = let all_names = List.rev_append (coupling_names model) (parameter_names model) in let lc_bundle = LCB.of_list all_names in let lc_set = List.fold_left - (fun acc s -> Sets.String.add s acc) - Sets.String.empty (LCB.base lc_bundle) + (fun acc s -> SSet.add s acc) + SSet.empty (LCB.base lc_bundle) and ambiguities = List.filter (fun (_, names) -> List.length names > 1) (LCB.fibers lc_bundle) in (lc_set, ambiguities) let disambiguate1 lc_set name = let rec disambiguate1' i = let name' = Printf.sprintf "%s_%d" name i in - let lc_name' = String.lowercase name' in - if Sets.String.mem lc_name' lc_set then + let lc_name' = ThoString.lowercase name' in + if SSet.mem lc_name' lc_set then disambiguate1' (succ i) else - (Sets.String.add lc_name' lc_set, name') in + (SSet.add lc_name' lc_set, name') in disambiguate1' 1 let disambiguate lc_set names = let _, replacements = List.fold_left (fun (lc_set', acc) name -> let lc_set'', name' = disambiguate1 lc_set' name in (lc_set'', SMap.add name name' acc)) (lc_set, SMap.empty) names in replacements let translate_parameters model = let lc_set, ambiguities = ambiguous_parameters model in let replacements = disambiguate lc_set (ThoList.flatmap snd ambiguities) in SMap.iter (Printf.eprintf "warning: case sensitive parameter names: renaming '%s' -> '%s'\n") replacements; let input_parameters, derived_parameters = classify_parameters model and couplings = values model.couplings in { Coupling.input = List.map (translate_input replacements) input_parameters; Coupling.derived = List.map (translate_derived replacements) derived_parameters @ List.map (translate_coupling_constant replacements) couplings; Coupling.derived_arrays = [] } (* UFO requires us to look up the mass parameter to distinguish between massless and massive vectors. TODO: this is a candidate for another lookup table. *) let lorentz_of_particle p = match UFOx.Lorentz.omega p.Particle.spin with | Coupling.Vector -> - begin match String.uppercase p.Particle.mass with + begin match ThoString.uppercase p.Particle.mass with | "ZERO" -> Coupling.Vector | _ -> Coupling.Massive_Vector end | s -> s type state = { directory : string; model : t } let initialized = ref None let is_initialized_from dir = match !initialized with | None -> false | Some state -> dir = state.directory let dump_raw = ref false let init dir = let model = filter_unphysical (parse_directory dir) in if !dump_raw then dump model; let tables = Lookup.of_model model in let vertices () = translate_vertices model tables in let particle f = tables.Lookup.particle f in let lorentz f = lorentz_of_particle (particle f) in let gauge_symbol () = "?GAUGE?" in let constant_symbol s = s in let parameters = translate_parameters model in M.setup ~color:(fun f -> UFOx.Color.omega (particle f).Particle.color) ~nc:(fun () -> model.nc) ~pdg:(fun f -> (particle f).Particle.pdg_code) ~lorentz ~propagator:(fun f -> propagator_of_lorentz (lorentz f)) ~width:(fun f -> Coupling.Constant) ~goldstone:(fun f -> None) ~conjugate:tables.Lookup.conjugate ~fermion:(fun f -> fermion_of_lorentz (lorentz f)) ~vertices ~flavors:[("All Flavors", tables.Lookup.flavors)] ~parameters:(fun () -> parameters) ~flavor_of_string:tables.Lookup.flavor_of_string ~flavor_to_string:(fun f -> (particle f).Particle.name) ~flavor_to_TeX:(fun f -> (particle f).Particle.texname) ~flavor_symbol:tables.Lookup.flavor_symbol ~gauge_symbol ~mass_symbol:(fun f -> (particle f).Particle.mass) ~width_symbol:(fun f -> (particle f).Particle.width) ~constant_symbol; initialized := Some { directory = dir; model = model } let ufo_directory = ref Config.default_UFO_dir let load () = if is_initialized_from !ufo_directory then () else init !ufo_directory let include_all_fusions = ref false let fusions_of_model ?only model = let include_fusion = match !include_all_fusions, only with | true, _ | false, None -> (fun name -> true) - | false, Some names -> (fun name -> Sets.String.mem name names) + | false, Some names -> (fun name -> SSet.mem name names) in SMap.fold (fun name l acc -> if include_fusion name then List.fold_left (fun acc p -> let l' = Lorentz.permute p l in match l'.Lorentz.spins with | Lorentz.Unused -> acc | Lorentz.Unique spins -> (l'.Lorentz.name, spins, l'.Lorentz.structure) :: acc | Lorentz.Ambiguous _ -> failwith "fusions: Lorentz.Ambiguous") [] (Permutation.Default.cyclic l.Lorentz.n) @ acc else acc) model.lorentz [] let fusions ?only () = match !initialized with | None -> [] | Some { model = model } -> fusions_of_model ?only model let include_hadrons = ref true module Whizard : sig val write : unit -> unit end = struct let write_header dir = Printf.printf "# WHIZARD Model file derived from UFO directory\n"; Printf.printf "# '%s'\n\n" dir; Printf.printf "model \"%s\"\n\n" (Filename.basename dir) let write_input_parameters parameters = let open Parameter in Printf.printf "# Independent (input) Parameters\n"; List.iter (fun p -> Printf.printf "parameter %s = %s\n" p.name (value_to_numeric p.value)) parameters; Printf.printf "\n" let write_derived_parameters parameters = let open Parameter in Printf.printf "# Dependent (derived) Parameters\n"; List.iter (fun p -> Printf.printf "derived %s = %s\n" p.name (value_to_expr alpha_s_half p.value)) parameters let write_particles particles = let open Particle in Printf.printf "# Particles\n"; Printf.printf "# NB: hypercharge assignments appear to be unreliable\n"; Printf.printf "# therefore we can't infer the isospin\n"; Printf.printf "# NB: parton-, gauge- & handedness are unavailable\n"; List.iter (fun p -> if not p.is_anti then begin Printf.printf "particle \"%s\" %d ### parton? gauge? left?\n" p.name p.pdg_code; Printf.printf " spin %s charge %s color %s ### isospin?\n" (UFOx.Lorentz.rep_to_string_whizard p.spin) (charge_to_string p.charge) (UFOx.Color.rep_to_string_whizard p.color); Printf.printf " name \"%s\"\n" p.name; if p.antiname <> p.name then Printf.printf " anti \"%s\"\n" p.antiname; Printf.printf " tex_name \"%s\"\n" p.texname; if p.antiname <> p.name then Printf.printf " tex_anti \"%s\"\n" p.antitexname; Printf.printf " mass %s width %s\n\n" p.mass p.width end) (values particles); Printf.printf "\n" let write_hadrons () = Printf.printf "# Hadrons (protons and beam remnants)\n"; Printf.printf "# NB: these are NOT part of the UFO model\n"; Printf.printf "# but added for WHIZARD's convenience!\n"; Printf.printf "particle PROTON 2212\n"; Printf.printf " spin 1/2 charge 1\n"; Printf.printf " name p \"p+\"\n"; Printf.printf " anti pbar \"p-\"\n"; Printf.printf "particle HADRON_REMNANT 90\n"; Printf.printf " name hr\n"; Printf.printf " tex_name \"had_r\"\n"; Printf.printf "particle HADRON_REMNANT_SINGLET 91\n"; Printf.printf " name hr1\n"; Printf.printf " tex_name \"had_r^{(1)}\"\n"; Printf.printf "particle HADRON_REMNANT_TRIPLET 92\n"; Printf.printf " color 3\n"; Printf.printf " name hr3\n"; Printf.printf " tex_name \"had_r^{(3)}\"\n"; Printf.printf " anti hr3bar\n"; Printf.printf " tex_anti \"had_r^{(\\bar 3)}\"\n"; Printf.printf "particle HADRON_REMNANT_OCTET 93\n"; Printf.printf " color 8\n"; Printf.printf " name hr8\n"; Printf.printf " tex_name \"had_r^{(8)}\"\n"; Printf.printf "\n" let write_vertices model vertices = Printf.printf "# Vertices (for phasespace generation only)\n"; Printf.printf "# NB: particles should be sorted increasing in mass.\n"; Printf.printf "# This is NOT implemented yet!\n"; List.iter (fun v -> let particles = String.concat " " (List.map (fun s -> "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"") (Array.to_list v.Vertex.particles)) in Printf.printf "vertex %s\n" particles) (values vertices); Printf.printf "\n" let write () = match !initialized with | None -> failwith "UFO.Whizard.write: UFO model not initialized" | Some { directory = dir; model = model } -> let input_parameters, derived_parameters = classify_parameters model in write_header dir; write_input_parameters input_parameters; write_derived_parameters derived_parameters; write_particles model.particles; if !include_hadrons then write_hadrons (); write_vertices model model.vertices; exit 0 end let options = Options.create [ ("UFO_dir", Arg.String (fun name -> ufo_directory := name), "UFO model directory (default: " ^ !ufo_directory ^ ")"); ("Majorana", Arg.Set use_majorana_spinors, "use Majorana spinors (must come _before_ exec!)"); ("verbatim_Hg", Arg.Set verbatim_higgs_glue, "don't correct the color flows for effective Higgs Gluon couplings"); ("write_WHIZARD", Arg.Unit Whizard.write, "write the WHIZARD model file (required once per model)"); ("long_flavors", Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long), "write use the UFO flavor names instead of integers"); ("dump", Arg.Set dump_raw, "dump UFO model for debugging the parser (must come _before_ exec!)"); ("all_fusions", Arg.Set include_all_fusions, "include all fusions in the fortran module"); ("no_hadrons", Arg.Clear include_hadrons, "don't add any particle not in the UFO file"); ("add_hadrons", Arg.Set include_hadrons, "add protons and beam remants for WHIZARD"); ("exec", Arg.Unit load, "load the UFO model files (required _before_ using particles names)"); ("help", Arg.Unit (fun () -> prerr_endline "..."), "print information on the model")] end module type Fortran_Target = sig val fuse : Algebra.QC.t -> string -> Coupling.lorentzn -> string -> string list -> string list -> Coupling.fusen -> unit val lorentz : - ?only:Sets.String.t -> Format_Fortran.formatter -> unit -> unit + ?only:SSet.t -> Format_Fortran.formatter -> unit -> unit val lorentz_module : - ?only:Sets.String.t -> ?name:string -> ?fortran_module:string -> + ?only:SSet.t -> ?name:string -> ?fortran_module:string -> Format_Fortran.formatter -> unit -> unit end module Targets = struct module Fortran : Fortran_Target = struct open Format_Fortran let fuse = UFO_targets.Fortran.fuse let lorentz_functions ff fusions () = List.iter (fun (name, s, l) -> UFO_targets.Fortran.lorentz ff name s l) fusions let lorentz ?only ff () = lorentz_functions ff (Model.fusions ?only ()) () let lorentz_module ?only ?(name="omega_amplitude_ufo") ?(fortran_module="omega95") ff () = let printf fmt = fprintf ff fmt and nl = pp_newline ff in printf "module %s" name; nl (); printf " use kinds"; nl (); printf " use %s" fortran_module; nl (); printf " implicit none"; nl (); printf " private"; nl (); let fusions = Model.fusions ?only () in List.iter (fun (name, _, _) -> printf " public :: %s" name; nl ()) fusions; UFO_targets.Fortran.eps4_g4_g44_decl ff (); UFO_targets.Fortran.eps4_g4_g44_init ff (); printf "contains"; nl (); lorentz_functions ff fusions (); printf "end module %s" name; nl (); pp_flush ff () end end module type Test = sig val suite : OUnit.test end module Test : Test = struct open OUnit let lexer s = UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string s)) let suite_lexer_escapes = "escapes" >::: [ "single-quote" >:: (fun () -> assert_equal (UFO_parser.STRING "a'b'c") (lexer "'a\\'b\\'c'")); "unterminated" >:: (fun () -> assert_raises End_of_file (fun () -> lexer "'a\\'b\\'c")) ] let suite_lexer = "lexer" >::: [suite_lexer_escapes] let suite = "UFO" >::: [suite_lexer] end Index: trunk/omega/src/try_ufo.sh =================================================================== --- trunk/omega/src/try_ufo.sh (revision 8305) +++ trunk/omega/src/try_ufo.sh (revision 8306) @@ -1,36 +1,37 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script takes TO's directory structure for granted. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## jobs=12 UFO_SM=$HOME/physics/SM/ UFO_MSSM=$HOME/physics/MSSM_UFO/ UFO_SMEFT=$HOME/physics/SMEFTsim_A_U35_alphaScheme_UFO_v2_1/ UFO_SMEFT=$HOME/physics/SMEFT_mW_UFO/ root=$HOME/physics/whizard -build=$root/_build +build=$root/_build/default omega=omega_UFO case X"$1" in X"-SM") UFO=$UFO_SM; shift;; X"-SMEFT") UFO=$UFO_SMEFT; shift;; X"-MSSM") UFO=$UFO_MSSM; omega=omega_UFO_Majorana; shift;; X"-X") UFO="$2"; shift 2;; *) UFO=$UFO_SM;; esac OCAMLFLAGS="-w -D -warn-error +P" make OCAMLFLAGS="$OCAMLFLAGS" -j $jobs -C $build/omega/src || exit 1 make -j $jobs -C $build/omega/bin $omega.opt || exit 1 omega="$build/omega/bin/$omega.opt -model:UFO_dir $UFO -model:exec -target:parameter_module parameters_ufo" +$omega -model:write_WHIZARD > omega_amplitude.mdl ( $omega -params; $omega -scatter "$1" ) > omega_amplitude.f90 gfortran -Wall -c -I ../../_build/omega/src/ omega_amplitude.f90 Index: trunk/omega/src/thoArray.ml =================================================================== --- trunk/omega/src/thoArray.ml (revision 8305) +++ trunk/omega/src/thoArray.ml (revision 8306) @@ -1,302 +1,306 @@ (* thoArray.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + type 'a compressed = { uniq : 'a array; embedding: int array } let uniq a = a.uniq let embedding a = a.embedding type 'a compressed2 = { uniq2 : 'a array array; embedding1: int array; embedding2: int array } let uniq2 a = a.uniq2 let embedding1 a = a.embedding1 let embedding2 a = a.embedding2 module PMap = Pmap.Tree let compress a = let last = Array.length a - 1 in let embedding = Array.make (succ last) (-1) in let rec scan num_uniq uniq elements n = if n > last then { uniq = Array.of_list (List.rev elements); embedding = embedding } else match PMap.find_opt compare a.(n) uniq with | Some n' -> embedding.(n) <- n'; scan num_uniq uniq elements (succ n) | None -> embedding.(n) <- num_uniq; scan (succ num_uniq) (PMap.add compare a.(n) num_uniq uniq) (a.(n) :: elements) (succ n) in scan 0 PMap.empty [] 0 let uncompress a = Array.map (Array.get a.uniq) a.embedding (* \begin{dubious} Using [transpose] simplifies the algorithms, but can be inefficient. If this turns out to be the case, we should add special treatments for symmetric matrices. \end{dubious} *) let transpose a = let dim1 = Array.length a and dim2 = Array.length a.(0) in let a' = Array.make_matrix dim2 dim1 a.(0).(0) in for i1 = 0 to pred dim1 do for i2 = 0 to pred dim2 do a'.(i2).(i1) <- a.(i1).(i2) done done; a' let compress2 a = let c2 = compress a in let c12_transposed = compress (transpose c2.uniq) in { uniq2 = transpose c12_transposed.uniq; embedding1 = c12_transposed.embedding; embedding2 = c2.embedding } let uncompress2 a = let a2 = uncompress { uniq = a.uniq2; embedding = a.embedding2 } in transpose (uncompress { uniq = transpose a2; embedding = a.embedding1 }) (* FIXME: not tail recursive! *) -let compare ?(cmp=Pervasives.compare) a1 a2 = +let compare ?(cmp=pcompare) a1 a2 = let l1 = Array.length a1 and l2 = Array.length a2 in if l1 < l2 then -1 else if l1 > l2 then 1 else let rec scan i = if i = l1 then 0 else let c = cmp a1.(i) a2.(i) in if c < 0 then -1 else if c > 0 then 1 else scan (succ i) in scan 0 let find_first f a = let l = Array.length a in let rec find_first' i = if i >= l then raise Not_found else if f (a.(i)) then i else find_first' (succ i) in find_first' 0 let match_first x a = find_first (fun x' -> x = x') a let find_all f a = let matches = ref [] in for i = Array.length a - 1 downto 0 do if f (a.(i)) then matches := i :: !matches done; !matches let match_all x a = find_all (fun x' -> x = x') a let num_rows a = Array.length a let num_columns a = match ThoList.classify (List.map Array.length (Array.to_list a)) with | [ (_, n) ] -> n | _ -> invalid_arg "ThoArray.num_columns: inhomogeneous array" module Test = struct open OUnit let test_compare_empty = "empty" >:: (fun () -> assert_equal 0 (compare [| |] [| |])) let test_compare_shorter = "shorter" >:: (fun () -> assert_equal (-1) (compare [|0|] [|0; 1|])) let test_compare_longer = "longer" >:: (fun () -> assert_equal ( 1) (compare [|0; 1|] [|0|])) let test_compare_less = "longer" >:: (fun () -> assert_equal (-1) (compare [|0; 1|] [|0; 2|])) let test_compare_equal = "equal" >:: (fun () -> assert_equal ( 0) (compare [|0; 1|] [|0; 1|])) let test_compare_more = "more" >:: (fun () -> assert_equal ( 1) (compare [|0; 2|] [|0; 1|])) let suite_compare = "compare" >::: [test_compare_empty; test_compare_shorter; test_compare_longer; test_compare_less; test_compare_equal; test_compare_more] let test_find_first_not_found = "not found" >:: (fun () -> assert_raises Not_found (fun () -> find_first (fun n -> n mod 2 = 0) [|1;3;5|])) let test_find_first_first = "first" >:: (fun () -> assert_equal 0 (find_first (fun n -> n mod 2 = 0) [|2;3;4;5|])) let test_find_first_not_last = "last" >:: (fun () -> assert_equal 1 (find_first (fun n -> n mod 2 = 0) [|1;2;3;4|])) let test_find_first_last = "not last" >:: (fun () -> assert_equal 1 (find_first (fun n -> n mod 2 = 0) [|1;2|])) let suite_find_first = "find_first" >::: [test_find_first_not_found; test_find_first_first; test_find_first_not_last; test_find_first_last] let test_find_all_empty = "empty" >:: (fun () -> assert_equal [] (find_all (fun n -> n mod 2 = 0) [|1;3;5|])) let test_find_all_first = "first" >:: (fun () -> assert_equal [0;2] (find_all (fun n -> n mod 2 = 0) [|2;3;4;5|])) let test_find_all_not_last = "last" >:: (fun () -> assert_equal [1;3] (find_all (fun n -> n mod 2 = 0) [|1;2;3;4;5|])) let test_find_all_last = "not last" >:: (fun () -> assert_equal [1;3] (find_all (fun n -> n mod 2 = 0) [|1;2;3;4|])) let suite_find_all = "find_all" >::: [test_find_all_empty; test_find_all_first; test_find_all_last; test_find_all_not_last] let test_num_columns_ok2 = "ok/2" >:: (fun () -> assert_equal 2 (num_columns [| [| 11; 12 |]; [| 21; 22 |]; [| 31; 32 |] |])) let test_num_columns_ok0 = "ok/0" >:: (fun () -> assert_equal 0 (num_columns [| [| |]; [| |]; [| |] |])) let test_num_columns_not_ok = "not_ok" >:: (fun () -> assert_raises (Invalid_argument "ThoArray.num_columns: inhomogeneous array") (fun () -> num_columns [| [| 11; 12 |]; [| 21 |]; [| 31; 32 |] |])) let suite_num_columns = "num_columns" >::: [test_num_columns_ok2; test_num_columns_ok0; test_num_columns_not_ok] let suite = "ThoArrays" >::: [suite_compare; suite_find_first; suite_find_all; suite_num_columns] end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/UFOx.mli =================================================================== --- trunk/omega/src/UFOx.mli (revision 8305) +++ trunk/omega/src/UFOx.mli (revision 8306) @@ -1,173 +1,175 @@ (* vertex.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module Expr : sig type t val of_string : string -> t val of_strings : string list -> t val substitute : string -> t -> t -> t val rename : (string * string) list -> t -> t val half : string -> t + val variables : t -> Sets.String_Caseless.t + val functions : t -> Sets.String_Caseless.t end module type Index = sig (* Indices are represented by a pair [int * 'r], where ['r] denotes the representation the index belongs to. *) (* [free indices] returns all free indices in the list [indices], i.\,e.~all positive indices. *) val free : (int * 'r) list -> (int * 'r) list (* [summation indices] returns all summation indices in the list [indices], i.\,e.~all negative indices. *) val summation : (int * 'r) list -> (int * 'r) list val classes_to_string : ('r -> string) -> (int * 'r) list -> string end module Index : Index module type Tensor = sig type atom (* A tensor is linear combination of products of [atom]s with rational coefficients. *) type t = (atom list * Algebra.Q.t) list (* We might need to replace atoms if the syntax is not context free. *) val map_atoms : (atom -> atom) -> t -> t (* We need to rename indices to implement permutations. *) val map_indices : (int -> int) -> t -> t (* Parsing and unparsing. Lists of [string]s are interpreted as sums. *) val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string (* The supported representations. *) type r val classify_indices : t -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool (* There is not a 1-to-1 mapping between the representations in the model files and the representations used by O'Mega, e.\,g.~in [Coupling.lorentz]. We might need to use heuristics. *) type r_omega val omega : r -> r_omega end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val of_expr : string -> UFOx_syntax.expr list -> t val to_string : t -> string type r val classify_indices : t list -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type t = private | Dirac of dirac | Vector of vector val map_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom : Lorentz_Atom module Lorentz : Tensor with type atom = Lorentz_Atom.t and type r_omega = Coupling.lorentz module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom : Color_Atom module Color : Tensor with type atom = Color_Atom.t and type r_omega = Color.t module Value : sig type t val of_expr : Expr.t -> t val to_string : t -> string val to_coupling : (string -> 'b) -> t -> 'b Coupling.expr end module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/fusion.ml =================================================================== --- trunk/omega/src/fusion.ml (revision 8305) +++ trunk/omega/src/fusion.ml (revision 8306) @@ -1,3345 +1,3349 @@ (* fusion.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + module type T = sig val options : Options.t type wf val conjugate : wf -> wf type flavor type flavor_sans_color val flavor : wf -> flavor val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list type braket val bra : braket -> wf val ket : braket -> rhs list type amplitude type amplitude_sans_color type selectors val amplitudes : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val allowed : amplitude -> bool val initialize_cache : string -> unit val set_cache_name : string -> unit val check_charges : unit -> flavor_sans_color list list val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list val poles : amplitude -> wf list list val s_channel : amplitude -> wf list val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig type flavor type stat exception Impossible val stat : flavor -> int -> stat val stat_fuse : Coupling.fermion_lines option -> stat list -> flavor -> stat val stat_keystone : Coupling.fermion_lines option -> stat list -> flavor -> stat val stat_sign : stat -> int (* debugging \ldots *) val stat_to_string : stat -> string val equal : stat -> stat -> bool val complete : stat -> bool end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor (* \thocwmodulesection{Dirac Fermions} *) exception Majorana module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor (* \begin{equation} \gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3) - \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1) \end{equation} *) type stat = | Fermion of int * (int option * int option) list | AntiFermion of int * (int option * int option) list | Boson of (int option * int option) list let lines_to_string lines = ThoList.to_string (function | Some i, Some j -> Printf.sprintf "%d>%d" i j | Some i, None -> Printf.sprintf "%d>*" i | None, Some j -> Printf.sprintf "*>%d" j | None, None -> "*>*") lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> List.sort compare l1 = List.sort compare l2 | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && List.sort compare l1 = List.sort compare l2 | _ -> false let complete = function | Boson _ -> true | _ -> false let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> raise Majorana | _ -> invalid_arg "Fusion.Stat_Dirac: invalid fermion number" exception Impossible let stat_fuse_pair_legacy f s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion _, Fermion _ | AntiFermion _, AntiFermion _ -> raise Impossible let stat_fuse_legacy s1 s23__n f = List.fold_right (stat_fuse_pair_legacy f) s23__n s1 let stat_fuse_legacy_logging s1 s23__n f = let s = stat_fuse_legacy s1 s23__n f in Printf.eprintf "Fusion.Stat_Dirac.stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string s); s module IMap = Map.Make (struct type t = int let compare = compare end) type partial = { stat : stat; fermions : int IMap.t; antifermions : int IMap.t; n : int } let partial_to_string p = Printf.sprintf "n = %d, fermions = %s, antifermions = %s, stat = %s" p.n (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.fermions)) (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.antifermions)) (stat_to_string p.stat) let add_lines l = function | Boson l' -> Boson (List.rev_append l l') | Fermion (n, l') -> Fermion (n, List.rev_append l l') | AntiFermion (n, l') -> AntiFermion (n, List.rev_append l l') let partial_of_slist slist = List.fold_left (fun acc s -> let n = succ acc.n in match s with | Boson l -> { acc with stat = add_lines l acc.stat; n } | Fermion (p, l) -> { acc with fermions = IMap.add n p acc.fermions; stat = add_lines l acc.stat; n } | AntiFermion (p, l) -> { acc with antifermions = IMap.add n p acc.antifermions; stat = add_lines l acc.stat; n } ) { stat = Boson []; fermions = IMap.empty; antifermions = IMap.empty; n = 0 } slist let find_opt p map = try Some (IMap.find p map) with Not_found -> None let match_fermion_line p (i, j) = if i <= p.n && j <= p.n then match find_opt i p.fermions, find_opt j p.antifermions with | (Some _ as f), (Some _ as fbar) -> { p with stat = add_lines [fbar, f] p.stat; fermions = IMap.remove i p.fermions; antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatch" else if i <= p.n then match find_opt i p.fermions, p.stat with | Some f, Boson l -> { p with stat = Fermion (f, l); fermions = IMap.remove i p.fermions } | _ -> invalid_arg "match_fermion_line: mismatch" else if j <= p.n then match find_opt j p.antifermions, p.stat with | Some fbar, Boson l -> { p with stat = AntiFermion (fbar, l); antifermions = IMap.remove j p.antifermions } | _ -> invalid_arg "match_fermion_line: mismatch" else failwith "match_fermion_line: impossible" let match_fermion_line_logging p (i, j) = Printf.eprintf "Fusion.match_fermion_line <<< %s (%d, %d)\n" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf "Fusion.match_fermion_line >>> %s\n" (partial_to_string p'); p' let match_fermion_lines flines s1 s23__n = let p = partial_of_slist (s1 :: s23__n) in List.fold_left match_fermion_line p flines let stat_fuse_new flines s1 s23__n f = (match_fermion_lines flines s1 s23__n).stat let stat_fuse_new_checking flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end; stat let stat_fuse_new_logging flines s1 s23__n f = Printf.eprintf "Fusion.Stat_Dirac.stat_fuse_new: \ connecting fermion lines %s in %s <- %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)); stat_fuse_new_checking flines s1 s23__n f let stat_fuse flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_fuse: empty" | s1 :: s23__n -> begin match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f | None -> stat_fuse_legacy s1 s23__n f end let stat_fuse_logging flines_opt slist f = Printf.eprintf "Fusion.Stat_Dirac.stat_fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string slist); stat_fuse flines_opt slist f let stat_keystone_legacy s1 s23__n f = let s2 = List.hd s23__n and s34__n = List.tl s23__n in stat_fuse_legacy s1 [stat_fuse_legacy s2 s34__n (M.conjugate f)] f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf "Fusion.Stat_Dirac.stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s let stat_keystone flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: empty" | s1 :: s23__n -> begin match flines_opt with | None -> stat_keystone_legacy s1 s23__n f | Some flines -> let stat = stat_fuse_new flines s1 s23__n f in if complete stat then stat else failwith (Printf.sprintf "Fusion.Stat_Dirac.stat_keystone: incomplete %s!" (stat_to_string stat)) end (* \begin{figure} \begin{displaymath} \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f1,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f3,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \qquad\qquad-\qquad \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f3,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f1,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \end{displaymath} \caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.} \end{figure} *) (* \begin{equation} \epsilon \left(\left\{ (0,1), (2,3) \right\}\right) = - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right) \end{equation} *) let permutation lines = let fout, fin = List.split lines in let eps_in, _ = Combinatorics.sort_signed fin and eps_out, _ = Combinatorics.sort_signed fout in (eps_in * eps_out) (* \begin{dubious} This comparing of permutations of fermion lines is a bit tedious and takes a macroscopic fraction of time. However, it's less than 20\,\%, so we don't focus on improving on it yet. \end{dubious} *) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation ((None, Some p) :: lines) | AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines) end (* \thocwmodulesection{Tags} *) module type Tags = sig type wf type coupling type 'a children val null_wf : wf val null_coupling : coupling val fuse : coupling -> wf children -> wf val wf_to_string : wf -> string option val coupling_to_string : coupling -> string option end module type Tagger = functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t module type Tagged_Maker = functor (Tagger : Tagger) -> functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant (* No tags is one option for good tags \ldots *) module No_Tags (PT : Tuple.Poly) = struct type wf = unit type coupling = unit type 'a children = 'a PT.t let null_wf = () let null_coupling = () let fuse () _ = () let wf_to_string () = None let coupling_to_string () = None end (* \begin{dubious} Here's a simple additive tag that can grow into something useful for loop calculations. \end{dubious} *) module Loop_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end module Order_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end (* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *) module Tagged (Tagger : Tagger) (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite let cache_option = ref Cache_Ignore type qcd_order = | QCD_order of int type ew_order = | EW_order of int let qcd_order = ref (QCD_order 99) let ew_order = ref (EW_order 99) let options = Options.create [ "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore), " ignore cached model tables (default)"; "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use), " use cached model tables"; "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite), " overwrite cached model tables"; "qcd", Arg.Int (fun n -> qcd_order := QCD_order n), " set QCD order n [>= 0, default = 99] (ignored)"; "ew", Arg.Int (fun n -> ew_order := EW_order n), " set QCD order n [>=0, default = 99] (ignored)"] exception Negative_QCD_order exception Negative_EW_order exception Vanishing_couplings exception Negative_QCD_EW_orders let int_orders = match !qcd_order, !ew_order with | QCD_order n, EW_order n' when n < 0 && n' >= 0 -> raise Negative_QCD_order | QCD_order n, EW_order n' when n >= 0 && n' < 0 -> raise Negative_EW_order | QCD_order n, EW_order n' when n < 0 && n' < 0 -> raise Negative_QCD_EW_orders | QCD_order n, EW_order n' -> (n, n') open Coupling module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) (* \begin{dubious} This is copied from [Colorize] and should be factored! \end{dubious} *) (* \begin{dubious} In the long run, it will probably be beneficial to apply the permutations in [Modeltools.add_vertexn]! \end{dubious} *) module PosMap = Partial.Make (struct type t = int let compare = compare end) let partial_map_undoing_permutation l l' = let module P = Permutation.Default in let p = P.of_list (List.map pred l') in PosMap.of_lists l (P.list p l) let partial_map_undoing_fuse fuse = partial_map_undoing_permutation (ThoList.range 1 (List.length fuse)) fuse let undo_permutation_of_fuse fuse = PosMap.apply_with_fallback (fun _ -> invalid_arg "permutation_of_fuse") (partial_map_undoing_fuse fuse) let fermion_lines = function | Coupling.V3 _ | Coupling.V4 _ -> None | Coupling.Vn (Coupling.UFO (_, _, _, fl, _), fuse, _) -> Some (UFO_Lorentz.map_fermion_lines (undo_permutation_of_fuse fuse) fl) type constant = M.constant (* \thocwmodulesubsection{Wave Functions} *) (* \begin{dubious} The code below is not yet functional. Too often, we assign to [Tags.null_wf] instead of calling [Tags.fuse]. \end{dubious} *) (* We will need two types of amplitudes: with color and without color. Since we can build them using the same types with only [flavor] replaced, it pays to use a functor to set up the scaffolding. *) module Tags = Tagger(PT) (* In the future, we might want to have [Coupling] among the functor arguments. However, for the moment, [Coupling] is assumed to be comprehensive. *) module type Tagged_Coupling = sig type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } val sign : t -> sign val coupling : t -> constant Coupling.t val coupling_tag : t -> string option end module Tagged_Coupling : Tagged_Coupling = struct type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } let sign c = c.sign let coupling c = c.coupling let coupling_tag_raw c = c.coupling_tag let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs) end (* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *) module type Amplitude = sig module Tags : Tags type flavor type p type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } val flavor : wf -> flavor val conjugate : wf -> wf val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option val wf_tag_raw : wf -> Tags.wf val order_wf : wf -> wf -> int val external_wfs : int -> (flavor * int) list -> wf list type 'a children type coupling = Tagged_Coupling.t type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list module D : DAG.T with type node = wf and type edge = coupling and type children = wf children val wavefunctions : braket list -> wf list type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val fusion_dag : amplitude -> D.t end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) : Amplitude with type p = P.t and type flavor = M.flavor and type 'a children = 'a PT.t and module Tags = Tags = struct type flavor = M.flavor type p = P.t module Tags = Tags type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let wf_tag wf = Tags.wf_to_string wf.wf_tag let wf_tag_raw wf = wf.wf_tag let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p; wf_tag = Tags.null_wf }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else let c = order_flavor wf1.flavor wf2.flavor in if c <> 0 then c else compare wf1.wf_tag wf2.wf_tag (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type coupling = Tagged_Coupling.t type 'a children = 'a PT.t type rhs = coupling * wf children let sign (c, _) = Tagged_Coupling.sign c let coupling (c, _) = Tagged_Coupling.coupling c let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c type exclusions = { x_flavors : flavor list; x_couplings : coupling list } let no_exclusions = { x_flavors = []; x_couplings = [] } let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module D = DAG.Make (DAG.Forest(PT) (struct type t = wf let compare = order_wf end) (struct type t = coupling let compare = compare end)) module WFSet = Set.Make (struct type t = wf let compare = order_wf end) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let variables a = List.map lhs a.fusions let dependencies a = a.dependencies let fusion_dag a = a.fusion_dag end module A = Amplitude(PT)(P)(M) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) let is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold collect_vertices flavors VSet.empty) [] (* Performance hack: *) type vertex_table = ((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list * ((A.flavor * A.flavor * A.flavor * A.flavor) * constant Coupling.vertex4 * constant) list * (A.flavor list * constant Coupling.vertexn * constant) list module VCache = Cache.Make (struct type t = vertex_table end) (struct type t = vertices end) let vertices_cache = ref None let hash () = VCache.hash (M.vertices ()) (* \begin{dubious} Can we do better than the executable name provided by [Config.cache_prefix]??? We need a better way to avoid collisions among the caches for different models in the same program. \end{dubious} *) let cache_name = ref (Config.cache_prefix ^ "." ^ Config.cache_suffix) let set_cache_name name = cache_name := name let initialize_cache dir = Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; VCache.write_dir (hash ()) dir !cache_name (vertices_nocache (M.max_degree ()) (M.flavors())); Printf.eprintf "done. <<< \n" let vertices max_degree flavors : vertices = match !vertices_cache with | None -> begin match !cache_option with | Cache_Use -> begin match VCache.maybe_read (hash ()) !cache_name with | VCache.Hit result -> result | VCache.Miss -> Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | VCache.Stale file -> Printf.eprintf " >>> Re-initializing stale vertex table %s in file %s. " !cache_name file; Printf.eprintf "This may take some time ... "; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result end | Cache_Overwrite -> Printf.eprintf " >>> Overwriting vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | Cache_Ignore -> let result = vertices_nocache max_degree flavors in vertices_cache := Some result; result end | Some result -> result (* Note that we must perform any filtering of the vertices \emph{after} caching, because the restrictions \emph{must not} influence the cache (unless we tag the cache with model and restrictions). *) (*i let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs let coupling_and_flavors_to_string (c, fs) = M.constant_symbol (unpack_constant c) ^ "[" ^ String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]" let fusions_to_string (f, cfs) = M.flavor_to_string f ^ " <- { " ^ String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^ " }" let vertices_to_string vertices = String.concat "; " (List.map fusions_to_string vertices) i*) let filter_vertices select_vtx vertices = List.fold_left (fun acc (f, cfs) -> let f' = M.conjugate f in let cfs = List.filter (fun (c, fs) -> select_vtx c f' (PT.to_list fs)) cfs in match cfs with | [] -> acc | cfs -> (f, cfs) :: acc) [] vertices (* \thocwmodulesubsection{Partitions} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let kmatrix_cuts c momenta = match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* Counting QCD and EW orders. *) let qcd_ew_check orders = if fst (orders) <= fst (int_orders) && snd (orders) <= snd (int_orders) then true else false (* Match a set of flavors to a set of momenta. Form the direct product for the lists of momenta two and three with the list of couplings and flavors two and three. *) let flavor_keystone select_p dim (f1, f23) (p1, p23) = ({ A.flavor = f1; A.momentum = P.of_ints dim p1; A.wf_tag = A.Tags.null_wf }, Product.fold2 (fun (c, f) p acc -> try let p' = PT.map (P.of_ints dim) p in if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then (c, PT.map2 (fun f'' p'' -> { A.flavor = f''; A.momentum = p''; A.wf_tag = A.Tags.null_wf }) f p') :: acc else acc with | PT.Mismatched_arity -> acc) f23 p23 []) (*i let cnt = ref 0 let gc_stat () = let minor, promoted, major = Gc.counters () in Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major let flavor_keystone select_p n (f1, f23) (p1, p23) = incr cnt; Gc.set { (Gc.get()) with Gc.space_overhead = 20 }; Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ()); flush stderr; flavor_keystone select_p n (f1, f23) (p1, p23) i*) (* Produce all possible combinations of vertices (flavor keystones) and momenta by forming the direct product. The semantically equivalent [Product.list2 (flavor_keystone select_wf n) vertices keystones] with \emph{subsequent} filtering would be a \emph{very bad} idea, because a potentially huge intermediate list is built for large models. E.\,g.~for the MSSM this would lead to non-termination by thrashing for $2\to4$ processes on most PCs. *) let flavor_keystones filter select_p dim vertices keystones = Product.fold2 (fun v k acc -> filter (flavor_keystone select_p dim v k) acc) vertices keystones [] (* Flatten the nested lists of vertices into a list of attached lines. *) let flatten_keystones t = ThoList.flatmap (fun (p1, p23) -> p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t (* \thocwmodulesubsection{Subtrees} *) (* Fuse a tuple of wavefunctions, keeping track of Fermi statistics. Record only the the sign \emph{relative} to the children. (The type annotation is only for documentation.) *) let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list = if PT.for_all (fun (wf, _) -> is_source wf) wfss then try let wfs, ss = PT.split wfss in let flavors = PT.map A.flavor wfs and momenta = PT.map A.momentum wfs - and wf_tags = PT.map A.wf_tag_raw wfs in +(*i and wf_tags = PT.map A.wf_tag_raw wfs i*) in let p = PT.fold_left_internal P.add momenta in (*i let wft = PT.fold_left Tags.fuse wf_tags in i*) List.fold_left (fun acc (f, c) -> if select_wf f p (PT.to_list momenta) && select_vtx c f (PT.to_list flavors) && kmatrix_cuts c momenta then (* [let _ = Printf.eprintf "Fusion.fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string M.flavor_to_string (PT.to_list flavors)) in] *) let s = S.stat_fuse (fermion_lines c) (PT.to_list ss) f in let flip = PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in ({ A.flavor = f; A.momentum = p; A.wf_tag = A.Tags.null_wf }, s, ({ Tagged_Coupling.sign = flip; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) :: acc else acc) [] (fuse_rhs flavors) with | P.Duplicate _ | S.Impossible -> [] else [] (* \begin{dubious} Eventually, the pairs of [tower] and [dag] in [fusion_tower'] below could and should be replaced by a graded [DAG]. This will look like, but currently [tower] containts statistics information that is missing from [dag]: \begin{quote} \verb+Type node = flavor * p is not compatible with type wf * stat+ \end{quote} This should be easy to fix. However, replacing [type t = wf] with [type t = wf * stat] is \emph{not} a good idea because the variable [stat] makes it impossible to test for the existance of a particular [wf] in a [DAG]. \end{dubious} \begin{dubious} In summary, it seems that [(wf * stat) list array * A.D.t] should be replaced by [(wf -> stat) * A.D.t]. \end{dubious} *) module GF = struct module Nodes = struct type t = A.wf module G = struct type t = int let compare = compare end let compare = A.order_wf let rank wf = P.rank wf.A.momentum end module Edges = struct type t = A.coupling let compare = compare end module F = DAG.Forest(PT)(Nodes)(Edges) type node = Nodes.t type edge = F.edge type children = F.children type t = F.t let compare = F.compare let for_all = F.for_all let fold = F.fold end module D' = DAG.Graded(GF) let tower_of_dag dag = let _, max_rank = D'.min_max_rank dag in Array.init max_rank (fun n -> D'.ranked n dag) (* The function [fusion_tower'] recursively builds the tower of all fusions from bottom up to a chosen level. The argument [tower] is an array of lists, where the $i$-th sublist (counting from 0) represents all off shell wave functions depending on $i+1$~momenta and their Fermistatistics. \begin{equation} \begin{aligned} \Bigl\lbrack & \{ \phi_1(p_1), \phi_2(p_2), \phi_3(p_3), \ldots \}, \\ & \{ \phi_{12}(p_1+p_2), \phi'_{12}(p_1+p_2), \ldots, \phi_{13}(p_1+p_3), \ldots, \phi_{23}(p_2+p_3), \ldots \}, \\ & \ldots \\ & \{ \phi_{1\cdots n}(p_1+\cdots+p_n), \phi'_{1\cdots n}(p_1+\cdots+p_n), \ldots \} \Bigr\rbrack \end{aligned} \end{equation} The argument [dag] is a DAG representing all the fusions calculated so far. NB: The outer array in [tower] is always very short, so we could also have accessed a list with [List.nth]. Appending of new members at the end brings no loss of performance. NB: the array is supposed to be immutable. *) (* The towers must be sorted so that the combinatorical functions can make consistent selections. \begin{dubious} Intuitively, this seems to be correct. However, one could have expected that no element appears twice and that this ordering is not necessary \ldots \end{dubious} *) let grow select_wf select_vtx tower = let rank = succ (Array.length tower) in - List.sort Pervasives.compare + List.sort pcompare (PT.graded_sym_power_fold rank (fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower []) let add_offspring dag (wf, _, rhs) = A.D.add_offspring wf rhs dag let filter_offspring fusions = List.map (fun (wf, s, _) -> (wf, s)) fusions let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t = if Array.length tower >= n_max then (tower, dag) else let tower' = grow select_wf select_vtx tower in fusion_tower' n_max select_wf select_vtx (Array.append tower [|filter_offspring tower'|]) (List.fold_left add_offspring dag tower') (* Discard the tower and return a map from wave functions to Fermistatistics together with the DAG. *) let make_external_dag wfs = List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs let mixed_fold_left f acc lists = Array.fold_left (List.fold_left f) acc lists module Stat_Map = Map.Make (struct type t = A.wf let compare = A.order_wf end) let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = let tower, dag = fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in let stats = mixed_fold_left (fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in ((fun wf -> Stat_Map.find wf stats), dag) (* Calculate the minimal tower of fusions that suffices for calculating the amplitude. *) let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (T.max_subtree n) select_wf select_vtx wfs (* Calculate the complete tower of fusions. It is much larger than required, but it allows a complete set of gauge checks. *) let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (List.length wfs - 1) select_wf select_vtx wfs (* \begin{dubious} There is a natural product of two DAGs using [fuse]. Can this be used in a replacement for [fusion_tower]? The hard part is to avoid double counting, of course. A straight forward solution could do a diagonal sum (in order to reject flipped offspring representing the same fusion) and rely on the uniqueness in [DAG] otherwise. However, this will (probably) slow down the procedure significanty, because most fusions (including Fermi signs!) will be calculated before being rejected by [DAG().add_offspring]. \end{dubious} *) (* Add to [dag] all Goldstone bosons defined in [tower] that correspond to gauge bosons in [dag]. This is only required for checking Slavnov-Taylor identities in unitarity gauge. Currently, it is not used, because we use the complete tower for gauge checking. *) let harvest_goldstones tower dag = A.D.fold_nodes (fun wf dag' -> match M.goldstone wf.A.flavor with | Some (g, _) -> let wf' = { wf with A.flavor = g } in if A.D.is_node wf' tower then begin A.D.harvest tower wf' dag' end else begin dag' end | None -> dag') dag dag (* Calculate the sign from Fermi statistics that is not already included in the children. *) let strip_fermion_lines = function | (Coupling.V3 _ | Coupling.V4 _ as v) -> v | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> Coupling.Vn (Coupling.UFO (c, l, s, [], col), f, x) let num_fermion_lines = function | Coupling.V3 _ | Coupling.V4 _ -> 0 | Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> List.length fl let stat_keystone v stats wf1 wfs = let wf1' = stats wf1 and wfs' = PT.map stats wfs in let f = A.flavor wf1 in let slist = PT.to_list wfs' @ [wf1'] in let stat = S.stat_keystone (fermion_lines v) slist f in if num_fermion_lines v < 2 then begin let legacy = S.stat_keystone None slist f in if not (S.equal stat legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: %s <> %s!" (S.stat_to_string legacy) (S.stat_to_string stat)); if not (S.complete legacy) then failwith (Printf.sprintf "Fusion.stat_keystone: legacy incomplete: %s!" (S.stat_to_string legacy)) end; if not (S.complete stat) then failwith (Printf.sprintf "Fusion.stat_keystone: incomplete: %s!" (S.stat_to_string stat)); stat_sign stat * PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs' let stat_keystone_logging v stats wf1 wfs = let sign = stat_keystone v stats wf1 wfs in Printf.eprintf "Fusion.stat_keystone: %s * %s -> %d\n" (M.flavor_to_string (A.flavor wf1)) (ThoList.to_string (fun wf -> M.flavor_to_string (A.flavor wf)) (PT.to_list wfs)) sign; sign (* Test all members of a list of wave functions are defined by the DAG simultaneously: *) let test_rhs dag (_, wfs) = PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs (* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag] and calculate the statistical factor depending on [stats] \emph{en passant}: *) let filter_keystone stats dag (wf1, pairs) acc = if is_source wf1 && A.D.is_node wf1 dag then match List.filter (test_rhs dag) pairs with | [] -> acc | pairs' -> (wf1, List.map (fun (c, wfs) -> ({ Tagged_Coupling.sign = stat_keystone c stats wf1 wfs; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p; A.wf_tag = A.Tags.null_wf }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make (struct type t = A.wf let compare = compare end) (* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all wavefunctions appearing in the amplitude [a]. *) let map_amplitude_wfs f a = let map_rhs (c, wfs) = (c, PT.map f wfs) in let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs) and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in let tower = map_dag a.A.fusion_tower and dag = map_dag a.A.fusion_dag in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in { A.fusions = List.map map_fusion a.A.fusions; A.brakets = List.map map_braket a.A.brakets; A.on_shell = a.A.on_shell; A.is_gauss = a.A.is_gauss; A.constraints = a.A.constraints; A.incoming = a.A.incoming; A.outgoing = a.A.outgoing; A.externals = List.map f a.A.externals; A.symmetry = a.A.symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (*i (* \begin{dubious} Just a silly little test: \end{dubious} *) let hack_amplitude = map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum }) i*) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (M.max_degree ()) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum; CA.wf_tag = wf.A.wf_tag } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } (* \begin{dubious} At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. \end{dubious} *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } end) (* \begin{dubious} For now, we can live with simple aggregation: \end{dubious} *) type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t } (* Not yet(?) needed: [module CS = Stat (CM)] *) let colorize_sterile_nodes dag f wf fibered_dag = if A.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { dag = CA.D.add_node wf' fibered_dag.dag; bundle = wf_bundle' } else fibered_dag let colorize_nodes f wf rhs fibered_dag = let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> CA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.dag in { dag = dag'; bundle = wf_bundle' } (* O'Caml (correctly) infers the type [val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag -> (CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) -> (D.node -> fibered_dag -> CA.D.node * CWFBundle.t) -> D.t -> CWFBundle.t -> fibered_dag]. *) let colorize_dag f_node f_ext dag wf_bundle = A.D.fold (colorize_nodes f_node) dag (A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag { dag = CA.D.empty; bundle = wf_bundle }) let colorize_external wf fibered_dag = match CWFBundle.inv_pi wf fibered_dag.bundle with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" let fuse_c_wf rhs = let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (_, c) -> kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) let colorize_coupling c coupling = { coupling with Tagged_Coupling.coupling = c } let colorize_fusion wf (coupling, children) fibered_dag = let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf) and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in let fusions = ThoList.flatmap (fun c_children -> List.map (fun (f, c) -> (colorize_wf f wf, (colorize_coupling c coupling, c_children))) (List.filter match_flavor (fuse_c_wf c_children))) (PT.product (PT.map find_colored children)) in let bundle = List.fold_right (fun (c_wf, _) -> CWFBundle.add c_wf) fusions fibered_dag.bundle in (fusions, bundle) let colorize_braket1 (wf, (coupling, children)) fibered_dag = let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in Product.fold2 (fun bra ket acc -> List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf ket)) (find_colored wf) (PT.product (PT.map find_colored children)) [] module CWFMap = Map.Make (struct type t = CA.wf let compare = CA.order_wf end) module CKetSet = Set.Make (struct type t = CA.rhs let compare = compare end) (* Find a set of kets in [map] that belong to [bra]. Return the empty set, if nothing is found. *) let lookup_ketset bra map = try CWFMap.find bra map with Not_found -> CKetSet.empty (* Return the set of kets belonging to [bra] in [map], augmented by [ket]. *) let addto_ketset bra ket map = CKetSet.add ket (lookup_ketset bra map) (* Augment or update [map] with a new [(bra, ket)] relation. *) let addto_ketset_map map (bra, ket) = CWFMap.add bra (addto_ketset bra ket map) map (* Take a list of [(bra, ket)] pairs and group the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) (* \begin{dubious} Isn't [Bundle]~\ref{Bundle} the correct framework for this? \end{dubious} *) let factorize_brakets brakets = CWFMap.fold (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc) (List.fold_left addto_ketset_map CWFMap.empty brakets) [] let colorize_braket (wf, rhs_list) fibered_dag = factorize_brakets (ThoList.flatmap (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag)) rhs_list) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (fun braket -> colorize_braket braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let allowed amplitude = match amplitude.CA.brakets with | [] -> false | _ -> true let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in if allowed amp then amp :: amps else amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes goldstones exclusions selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones exclusions selectors fin fout = amplitude goldstones selectors fin fout type flavor = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = CA.wf let conjugate = CA.conjugate let flavor = CA.flavor let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf) let momentum = CA.momentum let momentum_list = CA.momentum_list let wf_tag = CA.wf_tag type coupling = CA.coupling let sign = CA.sign let coupling = CA.coupling let coupling_tag = CA.coupling_tag type exclusions = CA.exclusions let no_exclusions = CA.no_exclusions type 'a children = 'a CA.children type rhs = CA.rhs let children = CA.children type fusion = CA.fusion let lhs = CA.lhs let rhs = CA.rhs type braket = CA.braket let bra = CA.bra let ket = CA.ket type amplitude = CA.amplitude type amplitude_sans_color = A.amplitude let incoming = CA.incoming let outgoing = CA.outgoing let externals = CA.externals let fusions = CA.fusions let brakets = CA.brakets let symmetry = CA.symmetry let on_shell = CA.on_shell let is_gauss = CA.is_gauss let constraints = CA.constraints let variables a = List.map lhs (fusions a) let dependencies = CA.dependencies (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let count_propagators a = List.length a.CA.fusions let count_fusions a = List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets + List.length a.CA.brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + CA.D.count_trees wf1 a.CA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23)) 0 a.CA.brakets exception Impossible let forest' a = let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.CA.brakets let cross wf = { CA.flavor = CM.conjugate wf.CA.flavor; CA.momentum = P.neg wf.CA.momentum; CA.wf_tag = wf.CA.wf_tag } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum; A.wf_tag = wf.A.wf_tag } let fuse_trees_uncolored wf ts = Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest_sans_color wf a = List.map (fuse_trees_uncolored wf) (forest_uncolored' a) i*) let poles_beneath wf dag = CA.D.eval_memoized (fun wf' -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs))) wf23)) a.CA.brakets module WFSet = Set.Make (struct type t = CA.wf let compare = CA.order_wf end) let s_channel a = WFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles a) WFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map CA.lhs a.CA.fusions let s_channel a = WFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles' a) WFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = CM.flavor_symbol wf.CA.flavor ^ String.concat "" (List.map p2s (P.to_ints wf.CA.momentum)) module Int = Map.Make (struct type t = int let compare = compare end) let add_to_list i n m = Int.add i (n :: try Int.find i m with Not_found -> []) m let classify_nodes dag = Int.fold (fun i n acc -> (i, n) :: acc) (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf) dag Int.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; CA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); CA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf) let bra_to_channel transform ch dag wf = let tree = A.D.dependencies dag wf in if Tree2.is_singleton tree then let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s tree else failwith "Fusion.phase_space_channels: wrong topology!" let ket_to_channel transform ch dag ket = Printf.fprintf ch "("; begin match A.children ket with | [] -> () | [child] -> below_to_channel transform ch dag child | child :: children -> below_to_channel transform ch dag child; List.iter (fun child -> Printf.fprintf ch ","; below_to_channel transform ch dag child) children end; Printf.fprintf ch ")" let phase_space_braket transform ch (bra, ket) dag = bra_to_channel transform ch dag bra; Printf.fprintf ch ": {"; begin match ket with | [] -> () | [ket1] -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1 | ket1 :: kets -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1; List.iter (fun k -> Printf.fprintf ch " \\\n | "; ket_to_channel transform ch dag k) kets end; Printf.fprintf ch " }\n" (*i Food for thought: let braket_to_tree2 dag (bra, ket) = let bra' = A.D.dependencies dag bra in if Tree2.is_singleton bra' then Tree2.cons [(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))] else failwith "Fusion.phase_space_channels: wrong topology!" let phase_space_braket transform ch (bra, ket) dag = let n2s wf = variable (transform wf) and e2s c = "" in Printf.fprintf ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket))) i*) let phase_space_channels_transformed transform ch a = List.iter (fun braket -> phase_space_braket transform ch braket a.A.fusion_dag) a.A.brakets let phase_space_channels ch a = phase_space_channels_transformed (fun wf -> wf) ch a let exchange_momenta_list p1 p2 p = List.map (fun pi -> if pi = p1 then p2 else if pi = p2 then p1 else pi) p let exchange_momenta p1 p2 p = P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p)) let flip_momenta wf = { wf with A.momentum = exchange_momenta 1 2 wf.A.momentum } let phase_space_channels_flipped ch a = phase_space_channels_transformed flip_momenta ch a end module Make = Tagged(No_Tags) module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary) module Tagged_Binary (T : Tagger) = Tagged(T)(Tuple.Binary)(Stat_Dirac)(Topology.Binary) (* \thocwmodulesection{Fusions with Majorana Fermions} *) module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor type stat = | Fermion of int * int list | AntiFermion of int * int list | Boson of int list | Majorana of int * int list let lines_to_string lines = ThoList.to_string string_of_int lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) | Majorana (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) let equal s1 s2 = match s1, s2 with | Boson l1, Boson l2 -> l1 = l2 | Majorana (p1, l1), Majorana (p2, l2) | Fermion (p1, l1), Fermion (p2, l2) | AntiFermion (p1, l1), AntiFermion (p2, l2) -> p1 = p2 && l1 = l2 | _ -> false let complete = function | Boson _ -> true | _ -> false let stat f p = match M.fermion f with | 0 -> Boson [] | 1 -> Fermion (p, []) | -1 -> AntiFermion (p, []) | 2 -> Majorana (p, []) | _ -> invalid_arg "Fusion.Stat_Majorana: invalid fermion number" (* \begin{JR} In the formalism of~\cite{Denner:Majorana}, it does not matter to distinguish spinors and conjugate spinors, it is only important to know in which direction a fermion line is calculated. So the sign is made by the calculation together with an aditional one due to the permuation of the pairs of endpoints of fermion lines in the direction they are calculated. We propose a ``canonical'' direction from the right to the left child at a fusion point so we only have to keep in mind which external particle hangs at each side. Therefore we need not to have a list of pairs of conjugate spinors and spinors but just a list in which the pairs are right-left-right-left and so on. Unfortunately it is unavoidable to have couplings with clashing arrows in supersymmetric theories so we need transmutations from fermions in antifermions and vice versa as well. \end{JR} *) exception Impossible (*i let stat_fuse s1 s2 f = match s1, s2, M.lorentz f with | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.Spinor -> Fermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2), _ -> Boson ([p; pbar] @ l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2), _ -> Boson ([pbar; p] @ l1 @ l2) | Fermion (pf, l1), Majorana (pm, l2), _ -> Boson ([pm; pf] @ l1 @ l2) | Majorana (pm, l1), Fermion (pf, l2), _ -> Boson ([pf; pm] @ l1 @ l2) | AntiFermion (pa, l1), Majorana (pm, l2), _ -> Boson ([pm; pa] @ l1 @ l2) | Majorana (pm, l1), AntiFermion (pa, l2), _ -> Boson ([pa; pm] @ l1 @ l2) | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Fermion _, Fermion _, _ | AntiFermion _, AntiFermion _, _ -> raise Impossible i*) let stat_fuse_pair_legacy f s1 s2 = match s1, s2, M.lorentz f with | Boson l1, Fermion (p, l2), Coupling.Majorana | Boson l1, AntiFermion (p, l2), Coupling.Majorana | Fermion (p, l1), Boson l2, Coupling.Majorana | AntiFermion (p, l1), Boson l2, Coupling.Majorana | Majorana (p, l1), Boson l2, Coupling.Majorana | Boson l1, Majorana (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Spinor | Boson l1, AntiFermion (p, l2), Coupling.Spinor | Fermion (p, l1), Boson l2, Coupling.Spinor | AntiFermion (p, l1), Boson l2, Coupling.Spinor | Majorana (p, l1), Boson l2, Coupling.Spinor | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.ConjSpinor | Boson l1, AntiFermion (p, l2), Coupling.ConjSpinor | Fermion (p, l1), Boson l2, Coupling.ConjSpinor | AntiFermion (p, l1), Boson l2, Coupling.ConjSpinor | Majorana (p, l1), Boson l2, Coupling.ConjSpinor | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Vectorspinor | Boson l1, AntiFermion (p, l2), Coupling.Vectorspinor | Fermion (p, l1), Boson l2, Coupling.Vectorspinor | AntiFermion (p, l1), Boson l2, Coupling.Vectorspinor | Majorana (p, l1), Boson l2, Coupling.Vectorspinor | Boson l1, Majorana (p, l2), Coupling.Vectorspinor -> Majorana (p, l1 @ l2) | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | AntiFermion (p1, l1), Fermion (p2, l2), _ | Fermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), AntiFermion (p2, l2), _ | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) let stat_fuse_pair_legacy_logging f s1 s2 = let stat = stat_fuse_pair_legacy f s1 s2 in Printf.eprintf "Fusion.Stat_Majorana.stat_fuse_pair_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string [s1; s2]) (stat_to_string stat); stat let stat_fuse_legacy s1 s23__n f = List.fold_left (stat_fuse_pair_legacy f) s1 s23__n let stat_fuse_legacy_logging s1 s23__n f = let stat = stat_fuse_legacy s1 s23__n f in Printf.eprintf "Fusion.Stat_Majorana.stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)) (stat_to_string stat); stat module IMap = Map.Make (struct type t = int let compare = compare end) type partial = { stat : stat; majoranas : int IMap.t; n : int } let partial_to_string p = Printf.sprintf "n = %d, majoranas = %s, stat = %s" p.n (ThoList.to_string (fun (i, f) -> Printf.sprintf "%d@%d" f i) (IMap.bindings p.majoranas)) (stat_to_string p.stat) let add_lines l = function | Boson l' -> Boson (l @ l') | Fermion (n, l') -> Fermion (n, l @ l') | AntiFermion (n, l') -> AntiFermion (n, l @ l') | Majorana (n, l') -> Majorana (n, l @ l') let partial_of_slist slist = List.fold_left (fun acc s -> let n = succ acc.n in match s with | Boson l -> { acc with stat = add_lines l acc.stat; n } | Fermion (p, l) -> invalid_arg "Fusion.Stat_Majorana.partial_of_slist: unexpected Fermion" | AntiFermion (p, l) -> invalid_arg "Fusion.Stat_Majorana.partial_of_slist: unexpected AntiFermion" | Majorana (p, l) -> { majoranas = IMap.add n p acc.majoranas; stat = add_lines l acc.stat; n } ) { stat = Boson []; majoranas = IMap.empty; n = 0 } slist let find_opt p map = try Some (IMap.find p map) with Not_found -> None let match_fermion_line p (i, j) = if i <= p.n && j <= p.n then match find_opt i p.majoranas, find_opt j p.majoranas with | Some f1, Some f2 -> { p with stat = add_lines [f2; f1] p.stat; majoranas = IMap.remove i (IMap.remove j p.majoranas) } | _ -> invalid_arg "match_fermion_line: mismatch" else if i <= p.n then match find_opt i p.majoranas, p.stat with | Some f, Boson l -> { p with stat = Majorana (f, l); majoranas = IMap.remove i p.majoranas } | _ -> invalid_arg "match_fermion_line: mismatch" else if j <= p.n then match find_opt j p.majoranas, p.stat with | Some f, Boson l -> { p with stat = Majorana (f, l); majoranas = IMap.remove j p.majoranas } | _ -> invalid_arg "match_fermion_line: mismatch" else failwith "match_fermion_line: impossible" let match_fermion_line_logging p (i, j) = Printf.eprintf "Fusion.match_fermion_line <<< %s (%d, %d)\n" (partial_to_string p) i j; let p' = match_fermion_line p (i, j) in Printf.eprintf "Fusion.match_fermion_line >>> %s\n" (partial_to_string p'); p' let match_fermion_lines flines s1 s23__n = let p = partial_of_slist (s1 :: s23__n) in List.fold_left match_fermion_line p flines let stat_fuse_new flines s1 s23__n f = (match_fermion_lines flines s1 s23__n).stat let stat_fuse_new_checking flines s1 s23__n f = let stat = stat_fuse_new flines s1 s23__n f in if List.length flines < 2 then begin let legacy = stat_fuse_legacy s1 s23__n f in if not (equal stat legacy) then failwith (Printf.sprintf "Fusion.Stat_Majorana.stat_fuse_new: %s <> %s!" (stat_to_string stat) (stat_to_string legacy)) end; stat let stat_fuse_new_logging flines s1 s23__n f = Printf.eprintf "Fusion.Stat_Majorana.stat_fuse_new: \ connecting fermion lines %s in %s <- %s\n" (UFO_Lorentz.fermion_lines_to_string flines) (M.flavor_to_string f) (ThoList.to_string stat_to_string (s1 :: s23__n)); stat_fuse_new_checking flines s1 s23__n f let stat_fuse flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Majorana.stat_fuse: empty" | s1 :: s23__n -> begin match flines_opt with | Some flines -> stat_fuse_new flines s1 s23__n f | None -> stat_fuse_legacy s1 s23__n f end let stat_fuse_logging flines_opt slist f = Printf.eprintf "Fusion.Stat_Majorana.stat_fuse: %s <- %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string slist); stat_fuse flines_opt slist f (* JRR's alogrithm depends on the ordering! *) let stat_keystone_legacy s1 s23__n f = let s2 = List.hd s23__n and s34__n = List.tl s23__n in stat_fuse_legacy (stat_fuse_legacy s2 s34__n (M.conjugate f)) [s1] f let stat_keystone_legacy_logging s1 s23__n f = let s = stat_keystone_legacy s1 s23__n f in Printf.eprintf "Fusion.Stat_Majorana.stat_keystone_legacy: %s (%s) %s -> %s\n" (stat_to_string s1) (M.flavor_to_string f) (ThoList.to_string stat_to_string s23__n) (stat_to_string s); s let stat_keystone flines_opt slist f = match slist with | [] -> invalid_arg "Fusion.Stat_Majorana.stat_keystone: empty" | s1 :: s23__n -> begin match flines_opt with | None -> stat_keystone_legacy s1 s23__n f | Some flines -> let stat = stat_fuse_new flines s1 s23__n f in if complete stat then stat else failwith (Printf.sprintf "Fusion.Stat_Majorana.stat_keystone: incomplete %s!" (stat_to_string stat)) end (*i These are the old Impossible raising rules. We keep them to ask Ohl what the generalized topologies do and if our stat_fuse does the right for 4-vertices with | Boson l1, AntiFermion (p, l2), _ | Fermion (p, l1), Boson l2, _ | AntiFermion (p, l1), Boson l2, _ | Majorana (p, l1), Boson l2, _ | Boson l1, Majorana (p, l2), _ -> raise Impossible i*) let permutation lines = fst (Combinatorics.sort_signed lines) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation (p :: lines) | AntiFermion (pbar, lines) -> permutation (pbar :: lines) | Majorana (pm, lines) -> permutation (pm :: lines) let stat_sign_logging stat = let sign = stat_sign stat in Printf.eprintf "Fusion.Stat_Majorana.stat_sign: %s -> %d\n" (stat_to_string stat) sign; sign end module Binary_Majorana = Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary) module Nary (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B)) module Nary_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B)) module Mixed23 = Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23) module Mixed23_Majorana = Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23) module Helac (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B)) module Helac_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B)) (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type exclusions val no_exclusions : exclusions type selectors type amplitudes val amplitudes : bool -> int option -> exclusions -> selectors -> process list -> amplitudes val empty : amplitudes val initialize_cache : string -> unit val set_cache_name : string -> unit val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list val process_table : amplitudes -> amplitude option array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), "report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "report progress to a file" ] type flavor = M.flavor type p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type exclusions = F.exclusions let no_exclusions = F.no_exclusions type selectors = F.selectors type flavors = flavor list array type helicities = int list array type colors = Color.Flow.t array type amplitudes' = amplitude array array array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; processes : amplitude list; process_table : amplitude option array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let processes a = a.processes let process_table a = a.process_table let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let sans_colors f = List.map CM.flavor_sans_color f let colors (fin, fout) = List.map M.color (fin @ fout) let process_sans_color a = (sans_colors (F.incoming a), sans_colors (F.outgoing a)) let color_flow a = CM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) let rec unphysical_of_lorentz = function | Coupling.Vector -> [4] | Coupling.Massive_Vector -> [4] | _ -> invalid_arg "unphysical_of_lorentz: not a vector particle" let unphysical_of_flavor f = unphysical_of_lorentz (M.lorentz f) let unphysical_of_flavors1 n f_list = ThoList.mapi (fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f) 1 f_list let unphysical_of_flavors n (fin, fout) = (unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout) let helicity_table unphysical flavors = let hs = begin match unphysical with | None -> List.map hs_of_flavors flavors | Some n -> List.map (unphysical_of_flavors n) flavors end in if not (ThoList.homogeneous hs) then invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!" else match hs with | [] -> [] | (hs_in, hs_out) :: _ -> sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out)) module Proc = Process.Make(M) module WFMap = Map.Make (struct type t = F.wf let compare = compare end) module WFSet2 = Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFMap2 = Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFTSet = Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end) (* All wavefunctions are unique per amplitude. So we can use per-amplitude dependency trees without additional \emph{internal} tags to identify identical wave functions. *) (* \textbf{NB:} we miss potential optimizations, because we assume all coupling to be different, while in fact we have horizontal/family symmetries and non abelian gauge couplings are universal anyway. *) let disambiguate_fusions amplitudes = let fusions = ThoList.flatmap (fun amplitude -> List.map (fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion))) (F.fusions amplitude)) amplitudes in let duplicates = List.fold_left (fun map (fusion, dependencies) -> let wf = F.lhs fusion in let set = try WFMap.find wf map with Not_found -> WFTSet.empty in WFMap.add wf (WFTSet.add dependencies set) map) WFMap.empty fusions in let multiplicity_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else WFMap.add wf cardinal acc) duplicates WFMap.empty and dictionary_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else snd (WFTSet.fold (fun dependency (i', acc') -> (succ i', WFMap2.add (wf, dependency) i' acc')) dependencies (1, acc))) duplicates WFMap2.empty in let multiplicity wf = WFMap.find wf multiplicity_map and dictionary amplitude wf = WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in (multiplicity, dictionary) let eliminate_common_fusions1 seen_wfs amplitude = List.fold_left (fun (seen, acc) f -> let wf = F.lhs f in let dependencies = F.dependencies amplitude wf in if WFSet2.mem (wf, dependencies) seen then (seen, acc) else (WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc)) seen_wfs (F.fusions amplitude) let eliminate_common_fusions processes = let _, rev_fusions = List.fold_left eliminate_common_fusions1 (WFSet2.empty, []) processes in List.rev rev_fusions (*i let eliminate_common_fusions processes = ThoList.flatmap (fun amplitude -> (List.map (fun f -> (f, amplitude)) (F.fusions amplitude))) processes i*) (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical exclusions select_wf processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones exclusions select_wf fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; let cf_array = Array.of_list color_flows in let ncf = Array.length cf_array in let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in for i = 0 to pred ncf do for j = 0 to i do color_factor_table.(i).(j) <- Color.Flow.factor cf_array.(i) cf_array.(j); color_factor_table.(j).(i) <- color_factor_table.(i).(j) done done; let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; processes = allowed; process_table = table; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf } let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; processes = []; process_table = Array.make_matrix 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None } end Index: trunk/omega/src/fusion_vintage.ml =================================================================== --- trunk/omega/src/fusion_vintage.ml (revision 8305) +++ trunk/omega/src/fusion_vintage.ml (revision 8306) @@ -1,2881 +1,2885 @@ (* fusion_vintage.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + module type T = sig val options : Options.t type wf val conjugate : wf -> wf type flavor type flavor_sans_color val flavor : wf -> flavor val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list type braket val bra : braket -> wf val ket : braket -> rhs list type amplitude type amplitude_sans_color type selectors val amplitudes : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val allowed : amplitude -> bool val initialize_cache : string -> unit val set_cache_name : string -> unit val check_charges : unit -> flavor_sans_color list list val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list val poles : amplitude -> wf list list val s_channel : amplitude -> wf list val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig type flavor type stat exception Impossible val stat : flavor -> int -> stat val stat_fuse : stat -> stat -> flavor -> stat val stat_sign : stat -> int val stat_to_string : stat -> string end module type Stat_Maker = functor (M : Model.T) -> Stat with type flavor = M.flavor (* \thocwmodulesection{Dirac Fermions} *) module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor (* \begin{equation} \gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3) - \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1) \end{equation} *) type stat = | Fermion of int * (int option * int option) list | AntiFermion of int * (int option * int option) list | Boson of (int option * int option) list let stat f p = let s = M.fermion f in if s = 0 then Boson [] else if s < 0 then AntiFermion (p, []) else (* [if s > 0 then] *) Fermion (p, []) let lines_to_string lines = ThoList.to_string (function | Some i, Some j -> Printf.sprintf "%d>%d" i j | Some i, None -> Printf.sprintf "%d>*" i | None, Some j -> Printf.sprintf "*>%d" j | None, None -> "*>*") lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) exception Impossible let stat_fuse s1 s2 f = match s1, s2 with | Boson l1, Boson l2 -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2) -> Boson ((Some pbar, Some p) :: l1 @ l2) | Fermion _, Fermion _ | AntiFermion _, AntiFermion _ -> raise Impossible (* \begin{figure} \begin{displaymath} \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f1,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f3,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \qquad\qquad-\qquad \parbox{26\unitlength}{% \begin{fmfgraph*}(25,15) \fmfstraight \fmfleft{f} \fmfright{f1,f2,f3} \fmflabel{$\psi(1)$}{f1} \fmflabel{$\bar\psi(2)$}{f2} \fmflabel{$\psi(3)$}{f3} \fmflabel{$0$}{f} \fmf{fermion}{f3,v1,f} \fmffreeze \fmf{fermion,tension=0.5}{f1,v2,f2} \fmf{photon}{v1,v2} \fmfdot{v1,v2} \end{fmfgraph*}} \end{displaymath} \caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.} \end{figure} *) (* \begin{equation} \epsilon \left(\left\{ (0,1), (2,3) \right\}\right) = - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right) \end{equation} *) let permutation lines = let fout, fin = List.split lines in let eps_in, _ = Combinatorics.sort_signed fin and eps_out, _ = Combinatorics.sort_signed fout in (eps_in * eps_out) (* \begin{dubious} This comparing of permutations of fermion lines is a bit tedious and takes a macroscopic fraction of time. However, it's less than 20\,\%, so we don't focus on improving on it yet. \end{dubious} *) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation ((None, Some p) :: lines) | AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines) end (* \thocwmodulesection{Tags} *) module type Tags = sig type wf type coupling type 'a children val null_wf : wf val null_coupling : coupling val fuse : coupling -> wf children -> wf val wf_to_string : wf -> string option val coupling_to_string : coupling -> string option end module type Tagger = functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t module type Tagged_Maker = functor (Tagger : Tagger) -> functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant (* No tags is one option for good tags \ldots *) module No_Tags (PT : Tuple.Poly) = struct type wf = unit type coupling = unit type 'a children = 'a PT.t let null_wf = () let null_coupling = () let fuse () _ = () let wf_to_string () = None let coupling_to_string () = None end (* \begin{dubious} Here's a simple additive tag that can grow into something useful for loop calculations. \end{dubious} *) module Loop_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end module Order_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end (* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *) module Tagged (Tagger : Tagger) (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite let cache_option = ref Cache_Ignore type qcd_order = | QCD_order of int type ew_order = | EW_order of int let qcd_order = ref (QCD_order 99) let ew_order = ref (EW_order 99) let options = Options.create [ "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore), " ignore cached model tables (default)"; "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use), " use cached model tables"; "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite), " overwrite cached model tables"; "qcd", Arg.Int (fun n -> qcd_order := QCD_order n), " set QCD order n [>= 0, default = 99] (ignored)"; "ew", Arg.Int (fun n -> ew_order := EW_order n), " set QCD order n [>=0, default = 99] (ignored)"] exception Negative_QCD_order exception Negative_EW_order exception Vanishing_couplings exception Negative_QCD_EW_orders let int_orders = match !qcd_order, !ew_order with | QCD_order n, EW_order n' when n < 0 && n' >= 0 -> raise Negative_QCD_order | QCD_order n, EW_order n' when n >= 0 && n' < 0 -> raise Negative_EW_order | QCD_order n, EW_order n' when n < 0 && n' < 0 -> raise Negative_QCD_EW_orders | QCD_order n, EW_order n' -> (n, n') open Coupling module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) let stat_fuse s f = PT.fold_right_internal (fun s' acc -> S.stat_fuse s' acc f) s type constant = M.constant (* \thocwmodulesubsection{Wave Functions} *) (* \begin{dubious} The code below is not yet functional. Too often, we assign to [Tags.null_wf] instead of calling [Tags.fuse]. \end{dubious} *) (* We will need two types of amplitudes: with color and without color. Since we can build them using the same types with only [flavor] replaced, it pays to use a functor to set up the scaffolding. *) module Tags = Tagger(PT) (* In the future, we might want to have [Coupling] among the functor arguments. However, for the moment, [Coupling] is assumed to be comprehensive. *) module type Tagged_Coupling = sig type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } val sign : t -> sign val coupling : t -> constant Coupling.t val coupling_tag : t -> string option end module Tagged_Coupling : Tagged_Coupling = struct type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } let sign c = c.sign let coupling c = c.coupling let coupling_tag_raw c = c.coupling_tag let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs) end (* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *) module type Amplitude = sig module Tags : Tags type flavor type p type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } val flavor : wf -> flavor val conjugate : wf -> wf val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option val wf_tag_raw : wf -> Tags.wf val order_wf : wf -> wf -> int val external_wfs : int -> (flavor * int) list -> wf list type 'a children type coupling = Tagged_Coupling.t type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list module D : DAG.T with type node = wf and type edge = coupling and type children = wf children val wavefunctions : braket list -> wf list type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val fusion_dag : amplitude -> D.t end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) : Amplitude with type p = P.t and type flavor = M.flavor and type 'a children = 'a PT.t and module Tags = Tags = struct type flavor = M.flavor type p = P.t module Tags = Tags type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let wf_tag wf = Tags.wf_to_string wf.wf_tag let wf_tag_raw wf = wf.wf_tag let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p; wf_tag = Tags.null_wf }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else let c = order_flavor wf1.flavor wf2.flavor in if c <> 0 then c else compare wf1.wf_tag wf2.wf_tag (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type coupling = Tagged_Coupling.t type 'a children = 'a PT.t type rhs = coupling * wf children let sign (c, _) = Tagged_Coupling.sign c let coupling (c, _) = Tagged_Coupling.coupling c let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c type exclusions = { x_flavors : flavor list; x_couplings : coupling list } let no_exclusions = { x_flavors = []; x_couplings = [] } let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module D = DAG.Make (DAG.Forest(PT) (struct type t = wf let compare = order_wf end) (struct type t = coupling let compare = compare end)) module WFSet = Set.Make (struct type t = wf let compare = order_wf end) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let variables a = List.map lhs a.fusions let dependencies a = a.dependencies let fusion_dag a = a.fusion_dag end module A = Amplitude(PT)(P)(M) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) let is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold collect_vertices flavors VSet.empty) [] (* Performance hack: *) type vertex_table = ((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list * ((A.flavor * A.flavor * A.flavor * A.flavor) * constant Coupling.vertex4 * constant) list * (A.flavor list * constant Coupling.vertexn * constant) list module VCache = Cache.Make (struct type t = vertex_table end) (struct type t = vertices end) let vertices_cache = ref None let hash () = VCache.hash (M.vertices ()) (* \begin{dubious} Can we do better than the executable name provided by [Config.cache_prefix]??? We need a better way to avoid collisions among the caches for different models in the same program. \end{dubious} *) let cache_name = ref (Config.cache_prefix ^ "." ^ Config.cache_suffix) let set_cache_name name = cache_name := name let initialize_cache dir = Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; VCache.write_dir (hash ()) dir !cache_name (vertices_nocache (M.max_degree ()) (M.flavors())); Printf.eprintf "done. <<< \n" let vertices max_degree flavors : vertices = match !vertices_cache with | None -> begin match !cache_option with | Cache_Use -> begin match VCache.maybe_read (hash ()) !cache_name with | VCache.Hit result -> result | VCache.Miss -> Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | VCache.Stale file -> Printf.eprintf " >>> Re-initializing stale vertex table %s in file %s. " !cache_name file; Printf.eprintf "This may take some time ... "; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result end | Cache_Overwrite -> Printf.eprintf " >>> Overwriting vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | Cache_Ignore -> let result = vertices_nocache max_degree flavors in vertices_cache := Some result; result end | Some result -> result (* Note that we must perform any filtering of the vertices \emph{after} caching, because the restrictions \emph{must not} influence the cache (unless we tag the cache with model and restrictions). *) (*i let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs let coupling_and_flavors_to_string (c, fs) = M.constant_symbol (unpack_constant c) ^ "[" ^ String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]" let fusions_to_string (f, cfs) = M.flavor_to_string f ^ " <- { " ^ String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^ " }" let vertices_to_string vertices = String.concat "; " (List.map fusions_to_string vertices) i*) let filter_vertices select_vtx vertices = List.fold_left (fun acc (f, cfs) -> let f' = M.conjugate f in let cfs = List.filter (fun (c, fs) -> select_vtx c f' (PT.to_list fs)) cfs in match cfs with | [] -> acc | cfs -> (f, cfs) :: acc) [] vertices (* \thocwmodulesubsection{Partitions} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let kmatrix_cuts c momenta = match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* Counting QCD and EW orders. *) let qcd_ew_check orders = if fst (orders) <= fst (int_orders) && snd (orders) <= snd (int_orders) then true else false (* Match a set of flavors to a set of momenta. Form the direct product for the lists of momenta two and three with the list of couplings and flavors two and three. *) let flavor_keystone select_p dim (f1, f23) (p1, p23) = ({ A.flavor = f1; A.momentum = P.of_ints dim p1; A.wf_tag = A.Tags.null_wf }, Product.fold2 (fun (c, f) p acc -> try let p' = PT.map (P.of_ints dim) p in if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then (c, PT.map2 (fun f'' p'' -> { A.flavor = f''; A.momentum = p''; A.wf_tag = A.Tags.null_wf }) f p') :: acc else acc with | PT.Mismatched_arity -> acc) f23 p23 []) (*i let cnt = ref 0 let gc_stat () = let minor, promoted, major = Gc.counters () in Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major let flavor_keystone select_p n (f1, f23) (p1, p23) = incr cnt; Gc.set { (Gc.get()) with Gc.space_overhead = 20 }; Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ()); flush stderr; flavor_keystone select_p n (f1, f23) (p1, p23) i*) (* Produce all possible combinations of vertices (flavor keystones) and momenta by forming the direct product. The semantically equivalent [Product.list2 (flavor_keystone select_wf n) vertices keystones] with \emph{subsequent} filtering would be a \emph{very bad} idea, because a potentially huge intermediate list is built for large models. E.\,g.~for the MSSM this would lead to non-termination by thrashing for $2\to4$ processes on most PCs. *) let flavor_keystones filter select_p dim vertices keystones = Product.fold2 (fun v k acc -> filter (flavor_keystone select_p dim v k) acc) vertices keystones [] (* Flatten the nested lists of vertices into a list of attached lines. *) let flatten_keystones t = ThoList.flatmap (fun (p1, p23) -> p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t (* \thocwmodulesubsection{Subtrees} *) (* Fuse a tuple of wavefunctions, keeping track of Fermi statistics. Record only the the sign \emph{relative} to the children. (The type annotation is only for documentation.) *) let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list = if PT.for_all (fun (wf, _) -> is_source wf) wfss then try let wfs, ss = PT.split wfss in let flavors = PT.map A.flavor wfs and momenta = PT.map A.momentum wfs - and wf_tags = PT.map A.wf_tag_raw wfs in +(*i and wf_tags = PT.map A.wf_tag_raw wfs i*) in let p = PT.fold_left_internal P.add momenta in (*i let wft = PT.fold_left Tags.fuse wf_tags in i*) List.fold_left (fun acc (f, c) -> if select_wf f p (PT.to_list momenta) && select_vtx c f (PT.to_list flavors) && kmatrix_cuts c momenta then let s = stat_fuse ss f in let flip = PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in ({ A.flavor = f; A.momentum = p; A.wf_tag = A.Tags.null_wf }, s, ({ Tagged_Coupling.sign = flip; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) :: acc else acc) [] (fuse_rhs flavors) with | P.Duplicate _ | S.Impossible -> [] else [] (* \begin{dubious} Eventually, the pairs of [tower] and [dag] in [fusion_tower'] below could and should be replaced by a graded [DAG]. This will look like, but currently [tower] containts statistics information that is missing from [dag]: \begin{quote} \verb+Type node = flavor * p is not compatible with type wf * stat+ \end{quote} This should be easy to fix. However, replacing [type t = wf] with [type t = wf * stat] is \emph{not} a good idea because the variable [stat] makes it impossible to test for the existance of a particular [wf] in a [DAG]. \end{dubious} \begin{dubious} In summary, it seems that [(wf * stat) list array * A.D.t] should be replaced by [(wf -> stat) * A.D.t]. \end{dubious} *) module GF = struct module Nodes = struct type t = A.wf module G = struct type t = int let compare = compare end let compare = A.order_wf let rank wf = P.rank wf.A.momentum end module Edges = struct type t = A.coupling let compare = compare end module F = DAG.Forest(PT)(Nodes)(Edges) type node = Nodes.t type edge = F.edge type children = F.children type t = F.t let compare = F.compare let for_all = F.for_all let fold = F.fold end module D' = DAG.Graded(GF) let tower_of_dag dag = let _, max_rank = D'.min_max_rank dag in Array.init max_rank (fun n -> D'.ranked n dag) (* The function [fusion_tower'] recursively builds the tower of all fusions from bottom up to a chosen level. The argument [tower] is an array of lists, where the $i$-th sublist (counting from 0) represents all off shell wave functions depending on $i+1$~momenta and their Fermistatistics. \begin{equation} \begin{aligned} \Bigl\lbrack & \{ \phi_1(p_1), \phi_2(p_2), \phi_3(p_3), \ldots \}, \\ & \{ \phi_{12}(p_1+p_2), \phi'_{12}(p_1+p_2), \ldots, \phi_{13}(p_1+p_3), \ldots, \phi_{23}(p_2+p_3), \ldots \}, \\ & \ldots \\ & \{ \phi_{1\cdots n}(p_1+\cdots+p_n), \phi'_{1\cdots n}(p_1+\cdots+p_n), \ldots \} \Bigr\rbrack \end{aligned} \end{equation} The argument [dag] is a DAG representing all the fusions calculated so far. NB: The outer array in [tower] is always very short, so we could also have accessed a list with [List.nth]. Appending of new members at the end brings no loss of performance. NB: the array is supposed to be immutable. *) (* The towers must be sorted so that the combinatorical functions can make consistent selections. \begin{dubious} Intuitively, this seems to be correct. However, one could have expected that no element appears twice and that this ordering is not necessary \ldots \end{dubious} *) let grow select_wf select_vtx tower = let rank = succ (Array.length tower) in - List.sort Pervasives.compare + List.sort pcompare (PT.graded_sym_power_fold rank (fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower []) let add_offspring dag (wf, _, rhs) = A.D.add_offspring wf rhs dag let filter_offspring fusions = List.map (fun (wf, s, _) -> (wf, s)) fusions let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t = if Array.length tower >= n_max then (tower, dag) else let tower' = grow select_wf select_vtx tower in fusion_tower' n_max select_wf select_vtx (Array.append tower [|filter_offspring tower'|]) (List.fold_left add_offspring dag tower') (* Discard the tower and return a map from wave functions to Fermistatistics together with the DAG. *) let make_external_dag wfs = List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs let mixed_fold_left f acc lists = Array.fold_left (List.fold_left f) acc lists module Stat_Map = Map.Make (struct type t = A.wf let compare = A.order_wf end) let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = let tower, dag = fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in let stats = mixed_fold_left (fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in ((fun wf -> Stat_Map.find wf stats), dag) (* Calculate the minimal tower of fusions that suffices for calculating the amplitude. *) let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (T.max_subtree n) select_wf select_vtx wfs (* Calculate the complete tower of fusions. It is much larger than required, but it allows a complete set of gauge checks. *) let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t = fusion_tower (List.length wfs - 1) select_wf select_vtx wfs (* \begin{dubious} There is a natural product of two DAGs using [fuse]. Can this be used in a replacement for [fusion_tower]? The hard part is to avoid double counting, of course. A straight forward solution could do a diagonal sum (in order to reject flipped offspring representing the same fusion) and rely on the uniqueness in [DAG] otherwise. However, this will (probably) slow down the procedure significanty, because most fusions (including Fermi signs!) will be calculated before being rejected by [DAG().add_offspring]. \end{dubious} *) (* Add to [dag] all Goldstone bosons defined in [tower] that correspond to gauge bosons in [dag]. This is only required for checking Slavnov-Taylor identities in unitarity gauge. Currently, it is not used, because we use the complete tower for gauge checking. *) let harvest_goldstones tower dag = A.D.fold_nodes (fun wf dag' -> match M.goldstone wf.A.flavor with | Some (g, _) -> let wf' = { wf with A.flavor = g } in if A.D.is_node wf' tower then begin A.D.harvest tower wf' dag' end else begin dag' end | None -> dag') dag dag (* Calculate the sign from Fermi statistics that is not already included in the children. \begin{dubious} The use of [PT.of2_kludge] is the largest skeleton on the cupboard of unified fusions. Currently, it is just another name for [PT.of2], but the existence of the latter requires binary fusions. Of course, this is just a symptom for not fully supporting four fermion vertices \ldots \end{dubious} *) let stat_keystone stats wf1 wfs = let wf1' = stats wf1 and wfs' = PT.map stats wfs in let stat = stat_fuse (PT.of2_kludge wf1' (stat_fuse wfs' (M.conjugate (A.flavor wf1)))) (A.flavor wf1) in (*i Printf.eprintf "Fusion.stat_keystone: %s\n" (S.stat_to_string stat); i*) stat_sign stat * PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs' (* Test all members of a list of wave functions are defined by the DAG simultaneously: *) let test_rhs dag (_, wfs) = PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs (* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag] and calculate the statistical factor depending on [stats] \emph{en passant}: *) let filter_keystone stats dag (wf1, pairs) acc = if is_source wf1 && A.D.is_node wf1 dag then match List.filter (test_rhs dag) pairs with | [] -> acc | pairs' -> (wf1, List.map (fun (c, wfs) -> ({ Tagged_Coupling.sign = stat_keystone stats wf1 wfs; Tagged_Coupling.coupling = c; Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p; A.wf_tag = A.Tags.null_wf }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make (struct type t = A.wf let compare = compare end) (* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all wavefunctions appearing in the amplitude [a]. *) let map_amplitude_wfs f a = let map_rhs (c, wfs) = (c, PT.map f wfs) in let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs) and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in let tower = map_dag a.A.fusion_tower and dag = map_dag a.A.fusion_dag in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in { A.fusions = List.map map_fusion a.A.fusions; A.brakets = List.map map_braket a.A.brakets; A.on_shell = a.A.on_shell; A.is_gauss = a.A.is_gauss; A.constraints = a.A.constraints; A.incoming = a.A.incoming; A.outgoing = a.A.outgoing; A.externals = List.map f a.A.externals; A.symmetry = a.A.symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (*i (* \begin{dubious} Just a silly little test: \end{dubious} *) let hack_amplitude = map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum }) i*) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (M.max_degree ()) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum; CA.wf_tag = wf.A.wf_tag } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } (* \begin{dubious} At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. \end{dubious} *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } end) (* \begin{dubious} For now, we can live with simple aggregation: \end{dubious} *) type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t } (* Not yet(?) needed: [module CS = Stat (CM)] *) let colorize_sterile_nodes dag f wf fibered_dag = if A.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { dag = CA.D.add_node wf' fibered_dag.dag; bundle = wf_bundle' } else fibered_dag let colorize_nodes f wf rhs fibered_dag = let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> CA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.dag in { dag = dag'; bundle = wf_bundle' } (* O'Caml (correctly) infers the type [val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag -> (CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) -> (D.node -> fibered_dag -> CA.D.node * CWFBundle.t) -> D.t -> CWFBundle.t -> fibered_dag]. *) let colorize_dag f_node f_ext dag wf_bundle = A.D.fold (colorize_nodes f_node) dag (A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag { dag = CA.D.empty; bundle = wf_bundle }) let colorize_external wf fibered_dag = match CWFBundle.inv_pi wf fibered_dag.bundle with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" let fuse_c_wf rhs = let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (_, c) -> kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) let colorize_coupling c coupling = { coupling with Tagged_Coupling.coupling = c } let colorize_fusion wf (coupling, children) fibered_dag = let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf) and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in let fusions = ThoList.flatmap (fun c_children -> List.map (fun (f, c) -> (colorize_wf f wf, (colorize_coupling c coupling, c_children))) (List.filter match_flavor (fuse_c_wf c_children))) (PT.product (PT.map find_colored children)) in let bundle = List.fold_right (fun (c_wf, _) -> CWFBundle.add c_wf) fusions fibered_dag.bundle in (fusions, bundle) let colorize_braket1 (wf, (coupling, children)) fibered_dag = let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in Product.fold2 (fun bra ket acc -> List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf ket)) (find_colored wf) (PT.product (PT.map find_colored children)) [] module CWFMap = Map.Make (struct type t = CA.wf let compare = CA.order_wf end) module CKetSet = Set.Make (struct type t = CA.rhs let compare = compare end) (* Find a set of kets in [map] that belong to [bra]. Return the empty set, if nothing is found. *) let lookup_ketset bra map = try CWFMap.find bra map with Not_found -> CKetSet.empty (* Return the set of kets belonging to [bra] in [map], augmented by [ket]. *) let addto_ketset bra ket map = CKetSet.add ket (lookup_ketset bra map) (* Augment or update [map] with a new [(bra, ket)] relation. *) let addto_ketset_map map (bra, ket) = CWFMap.add bra (addto_ketset bra ket map) map (* Take a list of [(bra, ket)] pairs and group the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) (* \begin{dubious} Isn't [Bundle]~\ref{Bundle} the correct framework for this? \end{dubious} *) let factorize_brakets brakets = CWFMap.fold (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc) (List.fold_left addto_ketset_map CWFMap.empty brakets) [] let colorize_braket (wf, rhs_list) fibered_dag = factorize_brakets (ThoList.flatmap (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag)) rhs_list) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (fun braket -> colorize_braket braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let allowed amplitude = match amplitude.CA.brakets with | [] -> false | _ -> true let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in if allowed amp then amp :: amps else amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes goldstones exclusions selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones exclusions selectors fin fout = amplitude goldstones selectors fin fout type flavor = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = CA.wf let conjugate = CA.conjugate let flavor = CA.flavor let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf) let momentum = CA.momentum let momentum_list = CA.momentum_list let wf_tag = CA.wf_tag type coupling = CA.coupling let sign = CA.sign let coupling = CA.coupling let coupling_tag = CA.coupling_tag type exclusions = CA.exclusions let no_exclusions = CA.no_exclusions type 'a children = 'a CA.children type rhs = CA.rhs let children = CA.children type fusion = CA.fusion let lhs = CA.lhs let rhs = CA.rhs type braket = CA.braket let bra = CA.bra let ket = CA.ket type amplitude = CA.amplitude type amplitude_sans_color = A.amplitude let incoming = CA.incoming let outgoing = CA.outgoing let externals = CA.externals let fusions = CA.fusions let brakets = CA.brakets let symmetry = CA.symmetry let on_shell = CA.on_shell let is_gauss = CA.is_gauss let constraints = CA.constraints let variables a = List.map lhs (fusions a) let dependencies = CA.dependencies (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let count_propagators a = List.length a.CA.fusions let count_fusions a = List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets + List.length a.CA.brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + CA.D.count_trees wf1 a.CA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23)) 0 a.CA.brakets exception Impossible let forest' a = let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.CA.brakets let cross wf = { CA.flavor = CM.conjugate wf.CA.flavor; CA.momentum = P.neg wf.CA.momentum; CA.wf_tag = wf.CA.wf_tag } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum; A.wf_tag = wf.A.wf_tag } let fuse_trees_uncolored wf ts = Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest_sans_color wf a = List.map (fuse_trees_uncolored wf) (forest_uncolored' a) i*) let poles_beneath wf dag = CA.D.eval_memoized (fun wf' -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs))) wf23)) a.CA.brakets module WFSet = Set.Make (struct type t = CA.wf let compare = CA.order_wf end) let s_channel a = WFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles a) WFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map CA.lhs a.CA.fusions let s_channel a = WFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles' a) WFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = CM.flavor_symbol wf.CA.flavor ^ String.concat "" (List.map p2s (P.to_ints wf.CA.momentum)) module Int = Map.Make (struct type t = int let compare = compare end) let add_to_list i n m = Int.add i (n :: try Int.find i m with Not_found -> []) m let classify_nodes dag = Int.fold (fun i n acc -> (i, n) :: acc) (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf) dag Int.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; CA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); CA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf) let bra_to_channel transform ch dag wf = let tree = A.D.dependencies dag wf in if Tree2.is_singleton tree then let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s tree else failwith "Fusion.phase_space_channels: wrong topology!" let ket_to_channel transform ch dag ket = Printf.fprintf ch "("; begin match A.children ket with | [] -> () | [child] -> below_to_channel transform ch dag child | child :: children -> below_to_channel transform ch dag child; List.iter (fun child -> Printf.fprintf ch ","; below_to_channel transform ch dag child) children end; Printf.fprintf ch ")" let phase_space_braket transform ch (bra, ket) dag = bra_to_channel transform ch dag bra; Printf.fprintf ch ": {"; begin match ket with | [] -> () | [ket1] -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1 | ket1 :: kets -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1; List.iter (fun k -> Printf.fprintf ch " \\\n | "; ket_to_channel transform ch dag k) kets end; Printf.fprintf ch " }\n" (*i Food for thought: let braket_to_tree2 dag (bra, ket) = let bra' = A.D.dependencies dag bra in if Tree2.is_singleton bra' then Tree2.cons [(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))] else failwith "Fusion.phase_space_channels: wrong topology!" let phase_space_braket transform ch (bra, ket) dag = let n2s wf = variable (transform wf) and e2s c = "" in Printf.fprintf ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket))) i*) let phase_space_channels_transformed transform ch a = List.iter (fun braket -> phase_space_braket transform ch braket a.A.fusion_dag) a.A.brakets let phase_space_channels ch a = phase_space_channels_transformed (fun wf -> wf) ch a let exchange_momenta_list p1 p2 p = List.map (fun pi -> if pi = p1 then p2 else if pi = p2 then p1 else pi) p let exchange_momenta p1 p2 p = P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p)) let flip_momenta wf = { wf with A.momentum = exchange_momenta 1 2 wf.A.momentum } let phase_space_channels_flipped ch a = phase_space_channels_transformed flip_momenta ch a end module Make = Tagged(No_Tags) module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary) module Tagged_Binary (T : Tagger) = Tagged(T)(Tuple.Binary)(Stat_Dirac)(Topology.Binary) (* \thocwmodulesection{Fusions with Majorana Fermions} *) module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) = struct type flavor = M.flavor type stat = | Fermion of int * int list | AntiFermion of int * int list | Boson of int list | Majorana of int * int list let stat f p = let s = M.fermion f in if s = 0 then Boson [] else if s < 0 then AntiFermion (p, []) else if s = 1 then (* [if s = 1 then] *) Fermion (p, []) else (* [if s > 1 then] *) Majorana (p, []) let lines_to_string lines = ThoList.to_string string_of_int lines let stat_to_string = function | Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines) | Fermion (p, lines) -> Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines) | AntiFermion (p, lines) -> Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines) | Majorana (p, lines) -> Printf.sprintf "Majorana (%d, %s)" p (lines_to_string lines) (* \begin{JR} In the formalism of~\cite{Denner:Majorana}, it does not matter to distinguish spinors and conjugate spinors, it is only important to know in which direction a fermion line is calculated. So the sign is made by the calculation together with an aditional one due to the permuation of the pairs of endpoints of fermion lines in the direction they are calculated. We propose a ``canonical'' direction from the right to the left child at a fusion point so we only have to keep in mind which external particle hangs at each side. Therefore we need not to have a list of pairs of conjugate spinors and spinors but just a list in which the pairs are right-left-right-left and so on. Unfortunately it is unavoidable to have couplings with clashing arrows in supersymmetric theories so we need transmutations from fermions in antifermions and vice versa as well. \end{JR} *) exception Impossible (*i let stat_fuse s1 s2 f = match s1, s2, M.lorentz f with | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, Coupling.Majorana -> Majorana (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.Spinor -> Fermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | AntiFermion (pbar, l1), Fermion (p, l2), _ -> Boson ([p; pbar] @ l1 @ l2) | Fermion (p, l1), AntiFermion (pbar, l2), _ -> Boson ([pbar; p] @ l1 @ l2) | Fermion (pf, l1), Majorana (pm, l2), _ -> Boson ([pm; pf] @ l1 @ l2) | Majorana (pm, l1), Fermion (pf, l2), _ -> Boson ([pf; pm] @ l1 @ l2) | AntiFermion (pa, l1), Majorana (pm, l2), _ -> Boson ([pm; pa] @ l1 @ l2) | Majorana (pm, l1), AntiFermion (pa, l2), _ -> Boson ([pa; pm] @ l1 @ l2) | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Fermion _, Fermion _, _ | AntiFermion _, AntiFermion _, _ -> raise Impossible i*) let stat_fuse s1 s2 f = match s1, s2, M.lorentz f with | Boson l1, Fermion (p, l2), Coupling.Majorana | Boson l1, AntiFermion (p, l2), Coupling.Majorana | Fermion (p, l1), Boson l2, Coupling.Majorana | AntiFermion (p, l1), Boson l2, Coupling.Majorana | Majorana (p, l1), Boson l2, Coupling.Majorana | Boson l1, Majorana (p, l2), Coupling.Majorana -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Spinor | Boson l1, AntiFermion (p, l2), Coupling.Spinor | Fermion (p, l1), Boson l2, Coupling.Spinor | AntiFermion (p, l1), Boson l2, Coupling.Spinor | Majorana (p, l1), Boson l2, Coupling.Spinor | Boson l1, Majorana (p, l2), Coupling.Spinor -> Fermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.ConjSpinor | Boson l1, AntiFermion (p, l2), Coupling.ConjSpinor | Fermion (p, l1), Boson l2, Coupling.ConjSpinor | AntiFermion (p, l1), Boson l2, Coupling.ConjSpinor | Majorana (p, l1), Boson l2, Coupling.ConjSpinor | Boson l1, Majorana (p, l2), Coupling.ConjSpinor -> AntiFermion (p, l1 @ l2) | Boson l1, Fermion (p, l2), Coupling.Vectorspinor | Boson l1, AntiFermion (p, l2), Coupling.Vectorspinor | Fermion (p, l1), Boson l2, Coupling.Vectorspinor | AntiFermion (p, l1), Boson l2, Coupling.Vectorspinor | Majorana (p, l1), Boson l2, Coupling.Vectorspinor | Boson l1, Majorana (p, l2), Coupling.Vectorspinor -> Majorana (p, l1 @ l2) | Boson l1, Boson l2, _ -> Boson (l1 @ l2) | AntiFermion (p1, l1), Fermion (p2, l2), _ | Fermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), AntiFermion (p2, l2), _ | Fermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), Fermion (p2, l2), _ | AntiFermion (p1, l1), Majorana (p2, l2), _ | Majorana (p1, l1), AntiFermion (p2, l2), _ | Majorana (p1, l1), Majorana (p2, l2), _ -> Boson ([p2; p1] @ l1 @ l2) | Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2) | Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2) | Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2) | Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2) | AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2) | Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2) let stat_fuse s1 s2 f = let stat = stat_fuse s1 s2 f in (*i Printf.eprintf "Fusion.Stat_Majorana.stat_fuse_legacy: %s <- %s -> %s\n" (M.flavor_to_string f) (ThoList.to_string stat_to_string [s1; s2]) (stat_to_string stat); i*) stat (*i These are the old Impossible raising rules. We keep them to ask Ohl what the generalized topologies do and if our stat_fuse does the right for 4-vertices with | Boson l1, AntiFermion (p, l2), _ | Fermion (p, l1), Boson l2, _ | AntiFermion (p, l1), Boson l2, _ | Majorana (p, l1), Boson l2, _ | Boson l1, Majorana (p, l2), _ -> raise Impossible i*) let permutation lines = fst (Combinatorics.sort_signed lines) let stat_sign = function | Boson lines -> permutation lines | Fermion (p, lines) -> permutation (p :: lines) | AntiFermion (pbar, lines) -> permutation (pbar :: lines) | Majorana (pm, lines) -> permutation (pm :: lines) end module Binary_Majorana = Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary) module Nary (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B)) module Nary_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B)) module Mixed23 = Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23) module Mixed23_Majorana = Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23) module Helac (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B)) module Helac_Majorana (B: Tuple.Bound) = Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B)) (* \thocwmodulesection{Multiple Amplitudes} *) module type Multi = sig exception Mismatch val options : Options.t type flavor type process = flavor list * flavor list type amplitude type fusion type wf type exclusions val no_exclusions : exclusions type selectors type amplitudes val amplitudes : bool -> int option -> exclusions -> selectors -> process list -> amplitudes val empty : amplitudes val initialize_cache : string -> unit val set_cache_name : string -> unit val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list val process_table : amplitudes -> amplitude option array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), "report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "report progress to a file" ] type flavor = M.flavor type p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type exclusions = F.exclusions let no_exclusions = F.no_exclusions type selectors = F.selectors type flavors = flavor list array type helicities = int list array type colors = Color.Flow.t array type amplitudes' = amplitude array array array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; processes : amplitude list; process_table : amplitude option array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let processes a = a.processes let process_table a = a.process_table let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let sans_colors f = List.map CM.flavor_sans_color f let colors (fin, fout) = List.map M.color (fin @ fout) let process_sans_color a = (sans_colors (F.incoming a), sans_colors (F.outgoing a)) let color_flow a = CM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) let rec unphysical_of_lorentz = function | Coupling.Vector -> [4] | Coupling.Massive_Vector -> [4] | _ -> invalid_arg "unphysical_of_lorentz: not a vector particle" let unphysical_of_flavor f = unphysical_of_lorentz (M.lorentz f) let unphysical_of_flavors1 n f_list = ThoList.mapi (fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f) 1 f_list let unphysical_of_flavors n (fin, fout) = (unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout) let helicity_table unphysical flavors = let hs = begin match unphysical with | None -> List.map hs_of_flavors flavors | Some n -> List.map (unphysical_of_flavors n) flavors end in if not (ThoList.homogeneous hs) then invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!" else match hs with | [] -> [] | (hs_in, hs_out) :: _ -> sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out)) module Proc = Process.Make(M) module WFMap = Map.Make (struct type t = F.wf let compare = compare end) module WFSet2 = Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFMap2 = Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFTSet = Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end) (* All wavefunctions are unique per amplitude. So we can use per-amplitude dependency trees without additional \emph{internal} tags to identify identical wave functions. *) (* \textbf{NB:} we miss potential optimizations, because we assume all coupling to be different, while in fact we have horizontal/family symmetries and non abelian gauge couplings are universal anyway. *) let disambiguate_fusions amplitudes = let fusions = ThoList.flatmap (fun amplitude -> List.map (fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion))) (F.fusions amplitude)) amplitudes in let duplicates = List.fold_left (fun map (fusion, dependencies) -> let wf = F.lhs fusion in let set = try WFMap.find wf map with Not_found -> WFTSet.empty in WFMap.add wf (WFTSet.add dependencies set) map) WFMap.empty fusions in let multiplicity_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else WFMap.add wf cardinal acc) duplicates WFMap.empty and dictionary_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else snd (WFTSet.fold (fun dependency (i', acc') -> (succ i', WFMap2.add (wf, dependency) i' acc')) dependencies (1, acc))) duplicates WFMap2.empty in let multiplicity wf = WFMap.find wf multiplicity_map and dictionary amplitude wf = WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in (multiplicity, dictionary) let eliminate_common_fusions1 seen_wfs amplitude = List.fold_left (fun (seen, acc) f -> let wf = F.lhs f in let dependencies = F.dependencies amplitude wf in if WFSet2.mem (wf, dependencies) seen then (seen, acc) else (WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc)) seen_wfs (F.fusions amplitude) let eliminate_common_fusions processes = let _, rev_fusions = List.fold_left eliminate_common_fusions1 (WFSet2.empty, []) processes in List.rev rev_fusions (*i let eliminate_common_fusions processes = ThoList.flatmap (fun amplitude -> (List.map (fun f -> (f, amplitude)) (F.fusions amplitude))) processes i*) (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical exclusions select_wf processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones exclusions select_wf fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; let cf_array = Array.of_list color_flows in let ncf = Array.length cf_array in let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in for i = 0 to pred ncf do for j = 0 to i do color_factor_table.(i).(j) <- Color.Flow.factor cf_array.(i) cf_array.(j); color_factor_table.(j).(i) <- color_factor_table.(i).(j) done done; let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; processes = allowed; process_table = table; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf } let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; processes = []; process_table = Array.make_matrix 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None } end Index: trunk/omega/src/UFOx.ml =================================================================== --- trunk/omega/src/UFOx.ml (revision 8305) +++ trunk/omega/src/UFOx.ml (revision 8306) @@ -1,920 +1,926 @@ (* vertex.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let error_in_string text start_pos end_pos = let i = max 0 start_pos.Lexing.pos_cnum in let j = min (String.length text) (max (i + 1) end_pos.Lexing.pos_cnum) in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) module Expr = struct type t = UFOx_syntax.expr let of_string text = try UFOx_parser.input UFOx_lexer.token (UFOx_lexer.init_position "" (Lexing.from_string text)) with + | UFO_tools.Lexical_Error (msg, start_pos, end_pos) -> + invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'" + msg (error_in_string text start_pos end_pos)) | UFOx_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let of_strings = function | [] -> UFOx_syntax.integer 0 | string :: strings -> List.fold_right (fun s acc -> UFOx_syntax.add (of_string s) acc) strings (of_string string) open UFOx_syntax let rec map f = function | Integer _ | Float _ as e -> e | Variable s as e -> begin match f s with | Some value -> value | None -> e end | Sum (e1, e2) -> Sum (map f e1, map f e2) | Difference (e1, e2) -> Difference (map f e1, map f e2) | Product (e1, e2) -> Product (map f e1, map f e2) | Quotient (e1, e2) -> Quotient (map f e1, map f e2) | Power (e1, e2) -> Power (map f e1, map f e2) | Application (s, el) -> Application (s, List.map (map f) el) let substitute name value expr = map (fun s -> if s = name then Some value else None) expr module SMap = Map.Make (struct type t = string let compare = compare end) let rename1 name_map name = try Some (Variable (SMap.find name name_map)) with Not_found -> None let rename alist_names value = let name_map = List.fold_left (fun acc (name, name') -> SMap.add name name' acc) SMap.empty alist_names in map (rename1 name_map) value let half name = Quotient (Variable name, Integer 2) + let variables = UFOx_syntax.variables + let functions = UFOx_syntax.functions + end let positive integers = List.filter (fun (i, _) -> i > 0) integers let not_positive integers = List.filter (fun (i, _) -> i <= 0) integers let int_list_to_string is = "[" ^ String.concat ", " (List.map string_of_int is) ^ "]" module type Index = sig (* Indices are represented by a pair [int * 'r], where ['r] denotes the representation the index belongs to. *) (* [free indices] returns all free indices in the list [indices], i.\,e.~all positive indices. *) val free : (int * 'r) list -> (int * 'r) list (* [summation indices] returns all summation indices in the list [indices], i.\,e.~all negative indices. *) val summation : (int * 'r) list -> (int * 'r) list val classes_to_string : ('r -> string) -> (int * 'r) list -> string end module Index : Index = struct let free i = positive i let summation i = not_positive i let classes_to_string rep_to_string index_classes = let reps = ThoList.uniq (List.sort compare (List.map snd index_classes)) in "[" ^ String.concat ", " (List.map (fun r -> (rep_to_string r) ^ "=" ^ (int_list_to_string (List.map fst (List.filter (fun (_, r') -> r = r') index_classes)))) reps) ^ "]" end module type Atom = sig type t val map_indices : (int -> int) -> t -> t val of_expr : string -> UFOx_syntax.expr list -> t val to_string : t -> string type r val classify_indices : t list -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Tensor = sig type atom type t = (atom list * Algebra.Q.t) list val map_atoms : (atom -> atom) -> t -> t val map_indices : (int -> int) -> t -> t val of_expr : UFOx_syntax.expr -> t val of_string : string -> t val of_strings : string list -> t val to_string : t -> string type r val classify_indices : t -> (int * r) list val rep_to_string : r -> string val rep_to_string_whizard : r -> string val rep_of_int : bool -> int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module Tensor (A : Atom) : Tensor with type atom = A.t and type r = A.r and type r_omega = A.r_omega = struct module S = UFOx_syntax module Q = Algebra.Q type atom = A.t type t = (atom list * Q.t) list let map_atoms f t = List.map (fun (atoms, q) -> (List.map f atoms, q)) t let map_indices f t = map_atoms (A.map_indices f) t let multiply (t1, c1) (t2, c2) = (List.sort compare (t1 @ t2), Q.mul c1 c2) let compress terms = List.map (fun (t, cs) -> (t, Q.sum cs)) (ThoList.factorize terms) let rec of_expr e = compress (of_expr' e) and of_expr' = function | S.Integer i -> [([], Q.make i 1)] | S.Float _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected float" | S.Variable name -> invalid_arg ("UFOx.Tensor.of_expr: unexpected variable '" ^ name ^ "'") | S.Application (name, args) -> [([A.of_expr name args], Q.unit)] | S.Sum (e1, e2) -> of_expr e1 @ of_expr e2 | S.Difference (e1, e2) -> of_expr e1 @ of_expr (S.Product (S.Integer (-1), e2)) | S.Product (e1, e2) -> Product.list2 multiply (of_expr e1) (of_expr e2) | S.Quotient (n, d) -> begin match of_expr d with | [([], q)] -> List.map (fun (t, c) -> (t, Q.div c q)) (of_expr n) | [] -> failwith "UFOx.Tensor.of_expr: zero denominator" | _ -> failwith "UFOx.Tensor.of_expr: only integer denominators allowed" end | S.Power (e, p) -> begin match of_expr e, of_expr p with | [([], q)], [([], p)] -> if Q.is_integer p then [([], Q.pow q (Q.to_integer p))] else failwith "UFOx.Tensor.of_expr: rational power" | [([], q)], _ -> failwith "UFOx.Tensor.of_expr: non-numeric power" | t, [([], p)] -> if Q.is_null (Q.sub p (Q.make 2 1)) then Product.list2 multiply t t else failwith "UFOx.Tensor.of_expr: only 2 as power of tensor allowed" | _ -> failwith "UFOx.Tensor.of_expr: power of tensor" end type r = A.r let rep_to_string = A.rep_to_string let rep_to_string_whizard = A.rep_to_string_whizard let rep_of_int = A.rep_of_int let rep_conjugate = A.rep_conjugate let rep_trivial = A.rep_trivial let classify_indices' filter tensors = ThoList.uniq (List.sort compare (List.map (fun (t, c) -> filter (A.classify_indices t)) tensors)) (* NB: the number of summation indices is not guarateed to be the same! Therefore it was foolish to try to check for uniqueness \ldots *) let classify_indices tensors = match classify_indices' Index.free tensors with | [] -> (* There's always at least an empty list! *) failwith "UFOx.Tensor.classify_indices: can't happen!" | [f] -> f | _ -> invalid_arg "UFOx.Tensor.classify_indices: incompatible free indices!" let of_expr e = let t = of_expr e in ignore (classify_indices t); t let of_string s = of_expr (Expr.of_string s) let of_strings s = of_expr (Expr.of_strings s) let term_to_string (tensors, c) = if Q.is_null c then "" else (if Q.is_negative c then " - " else " + ") ^ (let c = Q.abs c in if Q.is_unit c && tensors = [] then "" else Q.to_string c) ^ (match tensors with | [] -> "" | tensors -> (if Q.is_unit (Q.abs c) then "" else "*") ^ String.concat "*" (List.map A.to_string tensors)) let term_to_string (tensors, c) = if Q.is_null c then "" else (if Q.is_negative c then " - " else " + ") ^ (let c = Q.abs c in match tensors with | [] -> Q.to_string c | tensors -> String.concat "*" ((if Q.is_unit c then [] else [Q.to_string c]) @ List.map A.to_string tensors)) let to_string terms = String.concat "" (List.map term_to_string terms) type r_omega = A.r_omega let omega = A.omega end module type Lorentz_Atom = sig type dirac = private | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = (* private *) | Epsilon of int * int * int * int | Metric of int * int | P of int * int type t = private | Dirac of dirac | Vector of vector val map_indices_vector : (int -> int) -> vector -> vector end module Lorentz_Atom = struct type dirac = | C of int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int | ProjP of int * int | ProjM of int * int | Sigma of int * int * int * int type vector = | Epsilon of int * int * int * int | Metric of int * int | P of int * int type t = | Dirac of dirac | Vector of vector let map_indices_vector f = function | Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la) | Metric (mu, nu) -> Metric (f mu, f nu) | P (mu, n) -> P (f mu, f n) end module Lorentz_Atom' : Atom with type t = Lorentz_Atom.t and type r_omega = Coupling.lorentz = struct type t = Lorentz_Atom.t open Lorentz_Atom let map_indices_dirac f = function | C (i, j) -> C (f i, f j) | Gamma (mu, i, j) -> Gamma (f mu, f i, f j) | Gamma5 (i, j) -> Gamma5 (f i, f j) | Identity (i, j) -> Identity (f i, f j) | ProjP (i, j) -> ProjP (f i, f j) | ProjM (i, j) -> ProjM (f i, f j) | Sigma (mu, nu, i, j) -> Sigma (f mu, f nu, f i, f j) let map_indices f = function | Dirac d -> Dirac (map_indices_dirac f d) | Vector v -> Vector (map_indices_vector f v) let dirac_to_string = function | C (i, j) -> Printf.sprintf "C(%d,%d)" i j | Gamma (mu, i, j) -> Printf.sprintf "Gamma(%d,%d,%d)" mu i j | Gamma5 (i, j) -> Printf.sprintf "Gamma5(%d,%d)" i j | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j | ProjP (i, j) -> Printf.sprintf "ProjP(%d,%d)" i j | ProjM (i, j) -> Printf.sprintf "ProjM(%d,%d)" i j | Sigma (mu, nu, i, j) -> Printf.sprintf "Sigma(%d,%d,%d,%d)" mu nu i j let vector_to_string = function | Epsilon (mu, nu, ka, la) -> Printf.sprintf "Epsilon(%d,%d,%d,%d)" mu nu ka la | Metric (mu, nu) -> Printf.sprintf "Metric(%d,%d)" mu nu | P (mu, n) -> Printf.sprintf "P(%d,%d)" mu n let to_string = function | Dirac d -> dirac_to_string d | Vector v -> vector_to_string v module S = UFOx_syntax let of_expr name args = match name, args with | "C", [S.Integer i; S.Integer j] -> Dirac (C (i, j)) | "C", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to C()" | "Epsilon", [S.Integer mu; S.Integer nu; S.Integer ka; S.Integer la] -> Vector (Epsilon (mu, nu, ka, la)) | "Epsilon", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Epsilon()" | "Gamma", [S.Integer mu; S.Integer i; S.Integer j] -> Dirac (Gamma (mu, i, j)) | "Gamma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma()" | "Gamma5", [S.Integer i; S.Integer j] -> Dirac (Gamma5 (i, j)) | "Gamma5", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma5()" | "Identity", [S.Integer i; S.Integer j] -> Dirac (Identity (i, j)) | "Identity", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Identity()" | "Metric", [S.Integer mu; S.Integer nu] -> Vector (Metric (mu, nu)) | "Metric", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Metric()" | "P", [S.Integer mu; S.Integer n] -> Vector (P (mu, n)) | "P", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to P()" | "ProjP", [S.Integer i; S.Integer j] -> Dirac (ProjP (i, j)) | "ProjP", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjP()" | "ProjM", [S.Integer i; S.Integer j] -> Dirac (ProjM (i, j)) | "ProjM", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjM()" | "Sigma", [S.Integer mu; S.Integer nu; S.Integer i; S.Integer j] -> if mu <> nu then Dirac (Sigma (mu, nu, i, j)) else invalid_arg "UFOx.Lorentz.of_expr: implausible arguments to Sigma()" | "Sigma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Sigma()" | name, _ -> invalid_arg ("UFOx.Lorentz.of_expr: invalid tensor '" ^ name ^ "'") type r = S | V | Sp | CSp | Maj | Ghost let rep_trivial = function | S | Ghost -> true | V | Sp | CSp | Maj -> false let rep_to_string = function | S -> "0" | V -> "1" | Sp -> "1/2" | CSp-> "1/2bar" | Maj -> "1/2M" | Ghost -> "Ghost" let rep_to_string_whizard = function | S -> "0" | V -> "1" | Sp | CSp | Maj -> "1/2" | Ghost -> "Ghost" let rep_of_int neutral = function | -1 -> Ghost | 1 -> S | 2 -> if neutral then Maj else Sp | -2 -> if neutral then Maj else CSp | 3 -> V | _ -> invalid_arg "UFOx.Lorentz: impossible representation!" let rep_conjugate = function | S -> S | V -> V | Sp -> CSp (* ??? *) | CSp -> Sp (* ??? *) | Maj -> Maj | Ghost -> Ghost let classify_vector_indices1 = function | Epsilon (mu, nu, ka, la) -> [(mu, V); (nu, V); (ka, V); (la, V)] | Metric (mu, nu) -> [(mu, V); (nu, V)] | P (mu, n) -> [(mu, V)] let classify_dirac_indices1 = function | C (i, j) -> [(i, CSp); (j, Sp)] (* ??? *) | Gamma5 (i, j) | Identity (i, j) | ProjP (i, j) | ProjM (i, j) -> [(i, CSp); (j, Sp)] | Gamma (mu, i, j) -> [(mu, V); (i, CSp); (j, Sp)] | Sigma (mu, nu, i, j) -> [(mu, V); (nu, V); (i, CSp); (j, Sp)] let classify_indices1 = function | Dirac d -> classify_dirac_indices1 d | Vector v -> classify_vector_indices1 v let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) type r_omega = Coupling.lorentz let omega = function | S -> Coupling.Scalar | V -> Coupling.Vector | Sp -> Coupling.Spinor | CSp -> Coupling.ConjSpinor | Maj -> Coupling.Majorana | Ghost -> Coupling.Scalar end module Lorentz = Tensor(Lorentz_Atom') module type Color_Atom = sig type t = (* private *) | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom = struct type t = | Identity of int * int | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom' : Atom with type t = Color_Atom.t and type r_omega = Color.t = struct type t = Color_Atom.t module S = UFOx_syntax open Color_Atom let map_indices f = function | Identity (i, j) -> Identity (f i, f j) | Identity8 (a, b) -> Identity8 (f a, f b) | T (a, i, j) -> T (f a, f i, f j) | F (a, i, j) -> F (f a, f i, f j) | D (a, i, j) -> D (f a, f i, f j) | Epsilon (i, j, k) -> Epsilon (f i, f j, f k) | EpsilonBar (i, j, k) -> EpsilonBar (f i, f j, f k) | T6 (a, i', j') -> T6 (f a, f i', f j') | K6 (i', j, k) -> K6 (f i', f j, f k) | K6Bar (i', j, k) -> K6Bar (f i', f j, f k) let of_expr name args = match name, args with | "Identity", [S.Integer i; S.Integer j] -> Identity (i, j) | "Identity", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()" | "T", [S.Integer a; S.Integer i; S.Integer j] -> T (a, i, j) | "T", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T()" | "f", [S.Integer a; S.Integer b; S.Integer c] -> F (a, b, c) | "f", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to f()" | "d", [S.Integer a; S.Integer b; S.Integer c] -> D (a, b, c) | "d", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to d()" | "Epsilon", [S.Integer i; S.Integer j; S.Integer k] -> Epsilon (i, j, k) | "Epsilon", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Epsilon()" | "EpsilonBar", [S.Integer i; S.Integer j; S.Integer k] -> EpsilonBar (i, j, k) | "EpsilonBar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to EpsilonBar()" | "T6", [S.Integer a; S.Integer i'; S.Integer j'] -> T6 (a, i', j') | "T6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T6()" | "K6", [S.Integer i'; S.Integer j; S.Integer k] -> K6 (i', j, k) | "K6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6()" | "K6Bar", [S.Integer i'; S.Integer j; S.Integer k] -> K6Bar (i', j, k) | "K6Bar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6Bar()" | name, _ -> invalid_arg ("UFOx.Color.of_expr: invalid tensor '" ^ name ^ "'") let to_string = function | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j | Identity8 (a, b) -> Printf.sprintf "Identity8(%d,%d)" a b | T (a, i, j) -> Printf.sprintf "T(%d,%d,%d)" a i j | F (a, b, c) -> Printf.sprintf "f(%d,%d,%d)" a b c | D (a, b, c) -> Printf.sprintf "d(%d,%d,%d)" a b c | Epsilon (i, j, k) -> Printf.sprintf "Epsilon(%d,%d,%d)" i j k | EpsilonBar (i, j, k) -> Printf.sprintf "EpsilonBar(%d,%d,%d)" i j k | T6 (a, i', j') -> Printf.sprintf "T6(%d,%d,%d)" a i' j' | K6 (i', j, k) -> Printf.sprintf "K6(%d,%d,%d)" i' j k | K6Bar (i', j, k) -> Printf.sprintf "K6Bar(%d,%d,%d)" i' j k type r = S | Sbar | F | C | A let rep_trivial = function | S | Sbar -> true | F | C | A-> false let rep_to_string = function | S -> "1" | Sbar -> "1bar" | F -> "3" | C -> "3bar" | A-> "8" let rep_to_string_whizard = function | S -> "1" | Sbar -> "-1" | F -> "3" | C -> "-3" | A-> "8" let rep_of_int neutral = function | 1 -> S | -1 -> Sbar (* UFO appears to use this for colorless antiparticles!. *) | 3 -> F | -3 -> C | 8 -> A | 6 | -6 -> failwith "UFOx.Color: sextets not supported yet!" | _ -> invalid_arg "UFOx.Color: impossible representation!" let rep_conjugate = function | Sbar -> S | S -> Sbar | C -> F | F -> C | A -> A let classify_indices1 = function | Identity (i, j) -> [(i, C); (j, F)] | Identity8 (a, b) -> [(a, A); (b, A)] | T (a, i, j) -> [(i, F); (j, C); (a, A)] | Color_Atom.F (a, b, c) | D (a, b, c) -> [(a, A); (b, A); (c, A)] | Epsilon (i, j, k) -> [(i, F); (j, F); (k, F)] | EpsilonBar (i, j, k) -> [(i, C); (j, C); (k, C)] | T6 (a, i', j') -> failwith "UFOx.Color: sextets not supported yet!" | K6 (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" | K6Bar (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) type r_omega = Color.t (* FIXME: $N_C=3$ should not be hardcoded! *) let omega = function | S | Sbar -> Color.Singlet | F -> Color.SUN (3) | C -> Color.SUN (-3) | A-> Color.AdjSUN (3) end module Color = Tensor(Color_Atom') module Value = struct module S = UFOx_syntax module Q = Algebra.Q type builtin = | Sqrt | Cos | Sin | Tan | Exp | Atan | Conj let builtin_to_string = function | Sqrt -> "sqrt" | Cos -> "cos" | Tan -> "tan" | Sin -> "sin" | Exp -> "exp" | Atan -> "atan" | Conj -> "conjg" let builtin_of_string = function | "cmath.sqrt" -> Sqrt | "cmath.cos" -> Cos | "cmath.sin" -> Sin | "cmath.tan" -> Tan | "cmath.exp" -> Exp | "cmath.atan" -> Atan | "complexconjugate" -> Conj | name -> failwith ("UFOx.Value: unsupported function: " ^ name) type t = | Integer of int | Rational of Q.t | Real of float | Complex of float * float | Variable of string | Sum of t list | Difference of t * t | Product of t list | Quotient of t * t | Power of t * t | Application of builtin * t list let rec to_string = function | Integer i -> string_of_int i | Rational q -> Q.to_string q | Real x -> string_of_float x | Complex (0.0, 1.0) -> "I" | Complex (0.0, -1.0) -> "-I" | Complex (0.0, i) -> string_of_float i ^ "*I" | Complex (r, 1.0) -> string_of_float r ^ "+I" | Complex (r, -1.0) -> string_of_float r ^ "-I" | Complex (r, i) -> string_of_float r ^ (if i < 0.0 then "-" else "+") ^ string_of_float (abs_float i) ^ "*I" | Variable s -> s | Sum [] -> "0" | Sum [e] -> to_string e | Sum es -> "(" ^ String.concat "+" (List.map maybe_parentheses es) ^ ")" | Difference (e1, e2) -> to_string e1 ^ "-" ^ maybe_parentheses e2 | Product [] -> "1" | Product ((Integer (-1) | Real (-1.)) :: es) -> "-" ^ maybe_parentheses (Product es) | Product es -> String.concat "*" (List.map maybe_parentheses es) | Quotient (e1, e2) -> to_string e1 ^ "/" ^ maybe_parentheses e2 | Power (e1, e2) -> maybe_parentheses e1 ^ "^" ^ maybe_parentheses e2 | Application (f, [Integer i]) -> to_string (Application (f, [Real (float i)])) | Application (f, es) -> builtin_to_string f ^ "(" ^ String.concat "," (List.map to_string es) ^ ")" and maybe_parentheses = function | Integer i as e -> if i < 0 then "(" ^ to_string e ^ ")" else to_string e | Real x as e -> if x < 0.0 then "(" ^ to_string e ^ ")" else to_string e | Complex (x, 0.0) -> to_string (Real x) | Complex (0.0, 1.0) -> "I" | Variable _ | Power (_, _) | Application (_, _) as e -> to_string e | Sum [e] -> to_string e | Product [e] -> maybe_parentheses e | e -> "(" ^ to_string e ^ ")" let rec to_coupling atom = function | Integer i -> Coupling.Integer i | Rational q -> let n, d = Q.to_ratio q in Coupling.Quot (Coupling.Integer n, Coupling.Integer d) | Real x -> Coupling.Float x | Product es -> Coupling.Prod (List.map (to_coupling atom) es) | Variable s -> Coupling.Atom (atom s) | Complex (r, 0.0) -> Coupling.Float r | Complex (0.0, 1.0) -> Coupling.I | Complex (0.0, -1.0) -> Coupling.Prod [Coupling.I; Coupling.Integer (-1)] | Complex (0.0, i) -> Coupling.Prod [Coupling.I; Coupling.Float i] | Complex (r, 1.0) -> Coupling.Sum [Coupling.Float r; Coupling.I] | Complex (r, -1.0) -> Coupling.Diff (Coupling.Float r, Coupling.I) | Complex (r, i) -> Coupling.Sum [Coupling.Float r; Coupling.Prod [Coupling.I; Coupling.Float i]] | Sum es -> Coupling.Sum (List.map (to_coupling atom) es) | Difference (e1, e2) -> Coupling.Diff (to_coupling atom e1, to_coupling atom e2) | Quotient (e1, e2) -> Coupling.Quot (to_coupling atom e1, to_coupling atom e2) | Power (e1, Integer e2) -> Coupling.Pow (to_coupling atom e1, e2) | Power (e1, e2) -> Coupling.PowX (to_coupling atom e1, to_coupling atom e2) | Application (Sin, [e]) -> Coupling.Sin (to_coupling atom e) | Application (Cos, [e]) -> Coupling.Cos (to_coupling atom e) | Application (Tan, [e]) -> Coupling.Tan (to_coupling atom e) | Application (Exp, [e]) -> Coupling.Exp (to_coupling atom e) | Application (Atan, [e]) -> Coupling.Atan (to_coupling atom e) | Application (Sqrt, [e]) -> Coupling.Sqrt (to_coupling atom e) | Application (Conj, [e]) -> Coupling.Conj (to_coupling atom e) | Application (f, []) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": empty argument list") | Application (f, _::_) -> failwith ("UFOx.Value.to_coupling: " ^ builtin_to_string f ^ ": more than one argument list") let compress terms = terms let rec of_expr e = compress (of_expr' e) and of_expr' = function | S.Integer i -> Integer i | S.Float x -> Real x | S.Variable "cmath.pi" -> Variable "pi" | S.Variable name -> Variable name | S.Sum (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), e -> e | e, (Integer 0 | Real 0.) -> e | Sum e1, Sum e2 -> Sum (e1 @ e2) | e1, Sum e2 -> Sum (e1 :: e2) | Sum e1, e2 -> Sum (e2 :: e1) | e1, e2 -> Sum [e1; e2] end | S.Difference (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> e1 | e1, e2 -> Difference (e1, e2) end | S.Product (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), _ -> Integer 0 | _, (Integer 0 | Real 0.) -> Integer 0 | (Integer 1 | Real 1.), e -> e | e, (Integer 1 | Real 1.) -> e | Product e1, Product e2 -> Product (e1 @ e2) | e1, Product e2 -> Product (e1 :: e2) | Product e1, e2 -> Product (e2 :: e1) | e1, e2 -> Product [e1; e2] end | S.Quotient (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: divide by 0" | e1, (Integer 1 | Real 1.) -> e1 | e1, e2 -> Quotient (e1, e2) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | (Integer 0 | Real 0.), (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: 0^0" | _, (Integer 0 | Real 0.) -> Integer 1 | e, (Integer 1 | Real 1.) -> e | e, p -> Power (e, p) end | S.Application ("complex", [r; i]) -> begin match of_expr r, of_expr i with | r, (Integer 0 | Real 0.0) -> r | Real r, Real i -> Complex (r, i) | Integer r, Real i -> Complex (float_of_int r, i) | Real r, Integer i -> Complex (r, float_of_int i) | Integer r, Integer i -> Complex (float_of_int r, float_of_int i) | _ -> invalid_arg "UFOx.Value: complex expects two numeric arguments" end | S.Application ("complex", _) -> invalid_arg "UFOx.Value: complex expects two arguments" | S.Application ("complexconjugate", [e]) -> Application (Conj, [of_expr e]) | S.Application ("complexconjugate", _) -> invalid_arg "UFOx.Value: complexconjugate expects single argument" | S.Application ("cmath.sqrt", [e]) -> Application (Sqrt, [of_expr e]) | S.Application ("cmath.sqrt", _) -> invalid_arg "UFOx.Value: sqrt expects single argument" | S.Application (name, args) -> Application (builtin_of_string name, List.map of_expr args) end module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/vertex_syntax.ml =================================================================== --- trunk/omega/src/vertex_syntax.ml (revision 8305) +++ trunk/omega/src/vertex_syntax.ml (revision 8306) @@ -1,629 +1,633 @@ (* vertex_syntax.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + (* \thocwmodulesection{Abstract Syntax} *) exception Syntax_Error of string * Lexing.position * Lexing.position module Token = struct type t = | Digit of int | Token of string | Scripted of scripted | List of t list and scripted = { stem : t; prefix : prefix list; super : t list; sub : t list } and prefix = | Bar | Hat | Tilde | Dagger | Star | Prime let prefix_of_string = function | "\\bar" | "\\overline" -> Bar | "\\hat" | "\\widehat" -> Hat | "\\tilde" | "\\widetilde" -> Tilde | "\\dagger" -> Dagger | "*" | "\\ast" -> Star | "\\prime" -> Prime | _ -> invalid_arg "Vertex_Syntax.Token.string_to_prefix" let prefix_to_string = function | Bar -> "\\bar" | Hat -> "\\hat" | Tilde -> "\\tilde" | Dagger -> "\\dagger" | Star -> "*" | Prime -> "\\prime" let wrap_scripted = function | Scripted st -> st | t -> { stem = t; prefix = []; super = []; sub = [] } let wrap_list = function | List tl -> tl | _ as t -> [t] let digit i = if i >= 0 && i <= 9 then Digit i else invalid_arg ("Vertex_Syntax.Token.digit: " ^ string_of_int i) let token s = Token s let list = function | [] -> List [] | [Scripted {stem = t; prefix = []; super = []; sub = []}] -> t | [t] -> t | tl -> List tl let optional = function | None -> [] | Some t -> wrap_list t let scripted prefix token (super, sub) = match token, prefix, super, sub with | _, [], None, None -> token | (Digit _ | Token _ | List _) as t, _, _, _ -> Scripted { stem = t; prefix = List.map prefix_of_string prefix; super = optional super; sub = optional sub } | Scripted st, _, _, _ -> Scripted { stem = st.stem; prefix = List.map prefix_of_string prefix @ st.prefix; super = st.super @ optional super; sub = st.sub @ optional sub } let rec stem = function | Digit _ | Token _ as t -> t | Scripted { stem = t } -> stem t | List tl -> begin match List.rev tl with | [] -> List [] | t :: _ -> stem t end (* Strip superfluous [List] and [Scripted] constructors. *) (* NB: This might be unnecessary, if we used smart constructors. *) let rec strip = function | Digit _ | Token _ as t -> t | Scripted { stem = t; prefix = []; super = []; sub = [] } -> strip t | Scripted { stem = t; prefix = prefix; super = super; sub = sub } -> Scripted { stem = strip t; prefix = prefix; super = List.map strip super; sub = List.map strip sub } | List tl -> begin match List.map strip tl with | [] -> List [] | [t] -> t | tl -> List tl end (* Recursively merge nested [List] and [Scripted] constructors. *) (* NB: This might be unnecessary, if we used smart constructors. *) let rec flatten = function | Digit _ | Token _ as t -> t | List tl -> flatten_list tl | Scripted st -> flatten_scripted st and flatten_list tl = match List.map flatten tl with | [] -> List [] | [t] -> t | tl -> List tl and flatten_scripted = function | { stem = t; prefix = []; super = []; sub = [] } -> t | { stem = t; prefix = prefix; super = super; sub = sub } -> let super = List.map flatten super and sub = List.map flatten sub in begin match flatten t with | Digit _ | Token _ | List _ as t -> Scripted { stem = t; prefix = prefix; super = super; sub = sub } | Scripted st -> Scripted { stem = st.stem; prefix = prefix @ st.prefix; super = st.super @ super; sub = st.sub @ sub } end let ascii_A = Char.code 'A' let ascii_Z = Char.code 'Z' let ascii_a = Char.code 'a' let ascii_z = Char.code 'z' let is_char c = let a = Char.code c in (ascii_A <= a && a <= ascii_Z) || (ascii_a <= a && a <= ascii_z) let is_backslash c = c = '\\' let first_char s = s.[0] let last_char s = s.[String.length s - 1] let rec to_string = function | Digit i -> string_of_int i | Token s -> s | Scripted t -> scripted_to_string t | List tl -> "{" ^ list_to_string tl ^ "}" and list_to_string = function | [] -> "" | [Scripted { stem = t; super = []; sub = [] }] -> to_string t | [Scripted _ as t] -> "{" ^ to_string t ^ "}" | [t] -> to_string t | tl -> "{" ^ concat_tokens tl ^ "}" and scripted_to_string t = let super = match t.super with | [] -> "" | tl -> "^" ^ list_to_string tl and sub = match t.sub with | [] -> "" | tl -> "_" ^ list_to_string tl in String.concat "" (List.map prefix_to_string t.prefix) ^ to_string t.stem ^ super ^ sub and required_space t1 t2 = let required_space' s1 s2 = if is_backslash (first_char s2) then [] else if is_backslash (first_char s1) && is_char (last_char s1) then [Token " "] else [] in match t1, t2 with | Token s1, Token s2 -> required_space' s1 s2 | Scripted s1, Token s2 -> required_space' (scripted_to_string s1) s2 | Token s1, Scripted s2 -> required_space' s1 (scripted_to_string s2) | Scripted s1, Scripted s2 -> required_space' (scripted_to_string s1) (scripted_to_string s2) | List _, _ | _, List _ | _, Digit _ | Digit _, _ -> [] and interleave_spaces tl = ThoList.interleave_nearest required_space tl and concat_tokens tl = String.concat "" (List.map to_string (interleave_spaces tl)) let compare t1 t2 = - Pervasives.compare t1 t2 + pcompare t1 t2 end module Expr = struct type t = | Integer of int | Sum of t list | Diff of t * t | Product of t list | Ratio of t * t | Function of Token.t * t list let integer i = Integer i let rec add a b = match a, b with | Integer a, Integer b -> Integer (a + b) | Sum a, Sum b -> Sum (a @ b) | Sum a, b -> Sum (a @ [b]) | a, Sum b -> Sum (a :: b) | a, b -> Sum ([a; b]) (* (a1 - a2) - (b1 - b2) = (a1 + b2) - (a2 + b1) *) (* (a1 - a2) - b = a1 - (a2 + b) *) (* a - (b1 - b2) = (a + b2) - b1 *) and sub a b = match a, b with | Integer a, Integer b -> Integer (a - b) | Diff (a1, a2), Diff (b1, b2) -> Diff (add a1 b2, add a2 b1) | Diff (a1, a2), b -> Diff (a1, add a2 b) | a, Diff (b1, b2) -> Diff (add a b2, b1) | a, b -> Diff (a, b) and mult a b = match a, b with | Integer a, Integer b -> Integer (a * b) | Product a, Product b -> Product (a @ b) | Product a, b -> Product (a @ [b]) | a, Product b -> Product (a :: b) | a, b -> Product ([a; b]) and div a b = match a, b with | Ratio (a1, a2), Ratio (b1, b2) -> Ratio (mult a1 b2, mult a2 b1) | Ratio (a1, a2), b -> Ratio (a1, mult a2 b) | a, Ratio (b1, b2) -> Ratio (mult a b2, b1) | a, b -> Ratio (a, b) let apply f args = Function (f, args) let rec to_string = function | Integer i -> string_of_int i | Sum ts -> String.concat "+" (List.map to_string ts) | Diff (t1, t2) -> to_string t1 ^ "-" ^ to_string t2 | Product ts -> String.concat "*" (List.map to_string ts) | Ratio (t1, t2) -> to_string t1 ^ "/" ^ to_string t2 | Function (f, args) -> Token.to_string f ^ String.concat "" (List.map (fun arg -> "{" ^ to_string arg ^ "}") args) end (*i module TLSet = Set.Make (struct type t = Token.t list let compare = compare end) i*) module Particle = struct type name = | Neutral of Token.t | Charged of Token.t * Token.t type attr = | TeX of Token.t list | TeX_Anti of Token.t list | Alias of Token.t list | Alias_Anti of Token.t list | Fortran of Token.t list | Fortran_Anti of Token.t list | Spin of Expr.t | Charge of Expr.t | Color of Token.t list * Token.t list | Mass of Token.t list | Width of Token.t list (*i (* Combine the sets of aliases and use the rightmost version of the other attributes. *) let rec cons_attr a = function | [] -> [a] | a' :: alist -> match a, a' with | TeX tl, TeX tl' -> a' :: alist | TeX_Anti tl, TeX_Anti tl' -> a' :: alist | Aliases tl, Aliases tl' -> Aliases (TLSet.union tl tl') :: alist | Aliases_Anti tl, Aliases_Anti tl' -> Aliases_Anti (TLSet.union tl tl') :: alist | Fortran tl, Fortran tl' -> a' :: alist | Fortran_Anti tl, Fortran_Anti tl' -> a' :: alist | Spin tl, Spin tl' -> a' :: alist | Color tl, Color tl' -> a' :: alist | Charge tl, Charge tl' -> a' :: alist | Mass tl, Mass tl' -> a' :: alist | Width tl, Width tl' -> a' :: alist | _, _ -> a' :: cons_attr a alist i*) type t = { name : name; attr : attr list } let name_to_string = function | Neutral p -> "\\neutral{" ^ Token.to_string p ^ "}" | Charged (p, ap) -> "\\charged{" ^ Token.to_string p ^ "}{" ^ Token.to_string ap ^ "}" let attr_to_string = function | TeX tl -> "\\tex{" ^ Token.list_to_string tl ^ "}" | TeX_Anti tl -> "\\anti\\tex{" ^ Token.list_to_string tl ^ "}" | Alias tl -> "\\alias{" ^ Token.list_to_string tl ^ "}" | Alias_Anti tl -> "\\anti\\alias{" ^ Token.list_to_string tl ^ "}" | Fortran tl -> "\\fortran{" ^ Token.list_to_string tl ^ "}" | Fortran_Anti tl -> "\\anti\\fortran{" ^ Token.list_to_string tl ^ "}" | Spin e -> "\\spin{" ^ Expr.to_string e ^ "}" | Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}" | Color (group, rep) -> "\\color[" ^ Token.list_to_string group ^ "]{" ^ Token.list_to_string rep ^ "}" | Charge e -> "\\charge{" ^ Expr.to_string e ^ "}" | Mass tl -> "\\mass{" ^ Token.list_to_string tl ^ "}" | Width tl -> "\\width{" ^ Token.list_to_string tl ^ "}" let to_string p = name_to_string p.name ^ String.concat "" (List.map attr_to_string (List.sort compare p.attr)) end module Parameter = struct type attr = | TeX of Token.t list | Alias of Token.t list | Fortran of Token.t list type t' = { name : Token.t; value : Expr.t; attr : attr list} (*i let rec cons_attr a = function | [] -> [a] | a' :: alist -> match a, a' with | TeX tl, TeX tl' -> a' :: alist | Aliases tl, Aliases tl' -> Aliases (TLSet.union tl tl') :: alist | Fortran tl, Fortran tl' -> a' :: alist | _, _ -> a' :: cons_attr a alist i*) type t = | Parameter of t' | Derived of t' let attr_to_string = function | TeX tl -> "\\tex{" ^ Token.list_to_string tl ^ "}" | Alias tl -> "\\alias{" ^ Token.list_to_string tl ^ "}" | Fortran tl -> "\\fortran{" ^ Token.list_to_string tl ^ "}" let to_string' p = "{" ^ Token.to_string p.name ^ "}{" ^ Expr.to_string p.value ^ "}" ^ String.concat "" (List.map attr_to_string p.attr) let to_string = function | Parameter p -> "\\parameter" ^ to_string' p | Derived p -> "\\derived" ^ to_string' p end module Lie = struct type group = | SU of int | U of int | SO of int | O of int | Sp of int | E6 | E7 | E8 | F4 | G2 module T = Token let default_group = SU 3 let invalid_group s = invalid_arg ("Vertex.Lie.group_of_string: " ^ s) let series s name n = match name, n with | "SU", n when n > 1 -> SU n | "U", n when n >= 1 -> U n | "SO", n when n > 1 -> SO n | "O", n when n >= 1 -> O n | "Sp", n when n >= 2 -> Sp n | _ -> invalid_group s let exceptional s name n = match name, n with | "E", 6 -> E6 | "E", 7 -> E7 | "E", 8 -> E8 | "F", 4 -> F4 | "G", 2 -> G2 | _ -> invalid_group s let group_of_string s = try Scanf.sscanf s "%_[{]%[SUOp](%d)%_[}]%!" (series s) with | _ -> try Scanf.sscanf s "%_[{]%[EFG]_%d%_[}]%!" (exceptional s) with | _ -> invalid_group s let group_to_string = function | SU n -> "SU(" ^ string_of_int n ^ ")" | U n -> "U(" ^ string_of_int n ^ ")" | SO n -> "SO(" ^ string_of_int n ^ ")" | O n -> "O(" ^ string_of_int n ^ ")" | Sp n -> "Sp(" ^ string_of_int n ^ ")" | E6 -> "E6" | E7 -> "E7" | E8 -> "E8" | F4 -> "F4" | G2 -> "G2" type rep = int let rep_of_string group rep = match group with | SU 3 -> begin match rep with | "3" -> 3 | "\\bar 3" -> -3 | "8" -> 8 | _ -> invalid_arg ("Vertex.Lie.rep_of_string:" ^ " unsupported representation " ^ rep ^ " of " ^ group_to_string group) end | _ -> invalid_arg ("Vertex.Lie.rep_of_string:" ^ " unsupported group " ^ group_to_string group) let rep_to_string r = string_of_int r type t = group * rep end module Lorentz = struct type rep = | Scalar | Vector | Dirac | ConjDirac | Majorana | Weyl | ConjWeyl end module Index = struct type attr = | Color of Token.t list * Token.t list | Flavor of Token.t list * Token.t list | Lorentz of Token.t list type t = { name : Token.t; attr : attr list } let attr_to_string = function | Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}" | Color (group, rep) -> "\\color[" ^ Token.list_to_string group ^ "]{" ^ Token.list_to_string rep ^ "}" | Flavor ([], rep) -> "\\flavor{" ^ Token.list_to_string rep ^ "}" | Flavor (group, rep) -> "\\flavor[" ^ Token.list_to_string group ^ "]{" ^ Token.list_to_string rep ^ "}" | Lorentz tl -> "\\lorentz{" ^ Token.list_to_string tl ^ "}" let to_string i = "\\index{" ^ Token.to_string i.name ^ "}" ^ String.concat "" (List.map attr_to_string i.attr) end module Tensor = struct type attr = | Color of Token.t list * Token.t list | Flavor of Token.t list * Token.t list | Lorentz of Token.t list type t = { name : Token.t; attr : attr list } let attr_to_string = function | Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}" | Color (group, rep) -> "\\color[" ^ Token.list_to_string group ^ "]{" ^ Token.list_to_string rep ^ "}" | Flavor ([], rep) -> "\\flavor{" ^ Token.list_to_string rep ^ "}" | Flavor (group, rep) -> "\\flavor[" ^ Token.list_to_string group ^ "]{" ^ Token.list_to_string rep ^ "}" | Lorentz tl -> "\\lorentz{" ^ Token.list_to_string tl ^ "}" let to_string t = "\\tensor{" ^ Token.to_string t.name ^ "}" ^ String.concat "" (List.map attr_to_string t.attr) end module File_Tree = struct type declaration = | Particle of Particle.t | Parameter of Parameter.t | Index of Index.t | Tensor of Tensor.t | Vertex of Expr.t * Token.t | Include of string type t = declaration list let empty = [] end module File = struct type declaration = | Particle of Particle.t | Parameter of Parameter.t | Index of Index.t | Tensor of Tensor.t | Vertex of Expr.t * Token.t type t = declaration list let empty = [] (* We allow to include a file more than once, but we don't optimize by memoization, because we assume that this will be rare. However to avoid infinite loops when including a child, we make sure that it has not yet been included as a parent. *) let expand_includes parser unexpanded = let rec expand_includes' parents unexpanded expanded = List.fold_right (fun decl decls -> match decl with | File_Tree.Particle p -> Particle p :: decls | File_Tree.Parameter p -> Parameter p :: decls | File_Tree.Index i -> Index i :: decls | File_Tree.Tensor t -> Tensor t :: decls | File_Tree.Vertex (e, v) -> Vertex (e, v) :: decls | File_Tree.Include f -> if List.mem f parents then invalid_arg ("cyclic \\include{" ^ f ^ "}") else expand_includes' (f:: parents) (parser f) decls) unexpanded expanded in expand_includes' [] unexpanded [] let to_strings decls = List.map (function | Particle p -> Particle.to_string p | Parameter p -> Parameter.to_string p | Index i -> Index.to_string i | Tensor t -> Tensor.to_string t | Vertex (Expr.Integer 1, t) -> "\\vertex{" ^ Token.to_string t ^ "}" | Vertex (e, t) -> "\\vertex[" ^ Expr.to_string e ^ "]{" ^ Token.to_string t ^ "}") decls end Index: trunk/omega/src/opam_versions.sh =================================================================== --- trunk/omega/src/opam_versions.sh (revision 8305) +++ trunk/omega/src/opam_versions.sh (revision 8306) @@ -1,40 +1,40 @@ #! /bin/sh ######################################################################## # This script is for developers only and needs not to be portable. # This script assumes an opam installation with many versions of # O'Caml available as switches. ######################################################################## # tl;dr : don't try this at home, kids ;) ######################################################################## src=$(dirname $(realpath $0)) root=$(dirname $(dirname $src)) build=$root/_build log=$src/opam_versions.out versions="$1" if [ -z "$versions" ]; then versions="$(opam switch -s)" fi rm -f $log for switch in $versions; do opam switch $switch >/dev/null || exit 2 opam switch show eval $(opam env) - mkdir -p $build-$switch - cd $build-$switch + mkdir -p $build/$switch + cd $build/$switch if [ ! -e config.status ]; then - cp -a $build/config.status . + cp -a $build/default/config.status . ./config.status --recheck ./config.status fi make -j $(getconf _NPROCESSORS_ONLN) -C omega && \ make -j $(getconf _NPROCESSORS_ONLN) -C omega check if [ "$?" = 0 ]; then echo "$switch PASS" >> $log else echo "$switch FAIL" >> $log fi done Index: trunk/omega/src/Makefile.sources =================================================================== --- trunk/omega/src/Makefile.sources (revision 8305) +++ trunk/omega/src/Makefile.sources (revision 8306) @@ -1,296 +1,296 @@ # Makefile.sources -- Makefile component for O'Mega ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## ## We define the source files in a separate file so that they can be ## include by Makefiles in multiple directories. ## ######################################################################## ######################################################################## # # O'Caml sources # ######################################################################## # # NB: # # * all modules MUST be given in the correct sequence for linking # # * foo.ml as a source file implies foo.mli as a source files # # * we must use ocamlc -i to generate *_lexer.mli from *_lexer.ml in # order to treat *_lexer.ml like all other modules # # * automake conditionals are not available here, use # autoconf substitutions that expand to '#' or '' # ######################################################################## CASCADE_MLL = cascade_lexer.mll CASCADE_MLY = cascade_parser.mly CASCADE_MLD = $(CASCADE_MLL:.mll=.ml) $(CASCADE_MLY:.mly=.ml) CASCADE_ML_PRIMARY = cascade_syntax.ml cascade.ml CASCADE_ML = cascade_syntax.ml $(CASCADE_MLD) cascade.ml VERTEX_MLL = vertex_lexer.mll VERTEX_MLY = vertex_parser.mly VERTEX_MLD = $(VERTEX_MLL:.mll=.ml) $(VERTEX_MLY:.mly=.ml) VERTEX_ML_PRIMARY = vertex_syntax.ml vertex.ml VERTEX_ML = vertex_syntax.ml $(VERTEX_MLD) vertex.ml UFO_MLL = UFOx_lexer.mll UFO_lexer.mll UFO_MLY = UFOx_parser.mly UFO_parser.mly UFO_MLD = $(UFO_MLL:.mll=.ml) $(UFO_MLY:.mly=.ml) -UFO_ML_PRIMARY = UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml -UFO_ML = UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml +UFO_ML_PRIMARY = UFO_tools.ml UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml +UFO_ML = UFO_tools.ml UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml OMEGA_MLL = $(CASCADE_MLL) $(VERTEX_MLL) $(UFO_MLL) OMEGA_MLY = $(CASCADE_MLY) $(VERTEX_MLY) $(UFO_MLY) OMEGA_DERIVED_CAML = \ $(OMEGA_MLL:.mll=.mli) $(OMEGA_MLL:.mll=.ml) \ $(OMEGA_MLY:.mly=.mli) $(OMEGA_MLY:.mly=.ml) OMEGA_INTERFACES_MLI = \ coupling.mli \ model.mli \ target.mli ######################################################################## # We need lists of all modules including and excluding derived # files (*_PRIMARY). Unfortunately, we need the longer list in # proper linking order, so we can't just tack the additional # files to the end of the shorter list. ######################################################################## OMEGA_CORE_ML_PART1 = \ OUnit.ml OUnitDiff.ml \ - config.ml partial.ml pmap.ml sets.ml format_Fortran.ml \ - thoList.ml thoArray.ml thoString.ml bundle.ml powSet.ml \ + config.ml partial.ml pmap.ml format_Fortran.ml \ + thoString.ml sets.ml thoList.ml thoArray.ml bundle.ml powSet.ml \ thoFilename.ml cache.ml progress.ml trie.ml linalg.ml tree2.ml \ algebra.ml options.ml product.ml combinatorics.ml \ permutation.ml partition.ml tree.ml \ tuple.ml topology.ml DAG.ml momentum.ml phasespace.ml \ charges.ml color.ml modeltools.ml whizard.ml dirac.ml OMEGA_CORE_ML_PART2 = \ $(VERTEX_ML) $(UFO_ML) $(CASCADE_ML) OMEGA_CORE_ML_PART2_PRIMARY = \ $(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY) OMEGA_CORE_ML_PART3 = \ colorize.ml process.ml fusion.ml fusion_vintage.ml omega.ml OMEGA_CORE_ML_PRIMARY = \ $(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2_PRIMARY) $(OMEGA_CORE_ML_PART3) OMEGA_CORE_ML = \ $(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2) $(OMEGA_CORE_ML_PART3) OMEGA_CORE_MLI_PRIMARY = $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML_PRIMARY:.ml=.mli) OMEGA_CORE_MLI = $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML:.ml=.mli) OMEGA_MODELLIB_ML = \ modellib_SM.ml \ modellib_MSSM.ml \ modellib_NoH.ml \ modellib_NMSSM.ml \ modellib_PSSSM.ml \ modellib_BSM.ml \ modellib_WZW.ml \ modellib_Zprime.ml OMEGA_MODELLIB_MLI = $(OMEGA_MODELLIB_ML:.ml=.mli) OMEGA_TARGETLIB_ML = \ targets_Kmatrix.ml \ targets_Kmatrix_2.ml \ targets.ml OMEGA_TARGETLIB_MLI = $(OMEGA_TARGETLIB_ML:.ml=.mli) ######################################################################## # The supported models: ######################################################################## OMEGA_MINIMAL_APPLICATIONS_ML = \ omega_QED.ml \ omega_QCD.ml \ omega_SM.ml OMEGA_APPLICATIONS_ML = \ omega_QED.ml \ omega_QED_VM.ml \ omega_QCD.ml \ omega_QCD_VM.ml \ omega_SM.ml \ omega_SM_VM.ml \ omega_SM_CKM.ml \ omega_SM_CKM_VM.ml \ omega_SM_ac.ml \ omega_SM_ac_CKM.ml \ omega_SM_dim6.ml \ omega_SM_top.ml \ omega_SM_top_anom.ml \ omega_SM_tt_threshold.ml \ omega_SM_Higgs.ml \ omega_SM_Higgs_VM.ml \ omega_SM_Higgs_CKM.ml \ omega_SM_Higgs_CKM_VM.ml \ omega_THDM.ml \ omega_THDM_VM.ml \ omega_THDM_CKM.ml \ omega_THDM_CKM_VM.ml \ omega_MSSM.ml \ omega_MSSM_CKM.ml \ omega_MSSM_Grav.ml \ omega_MSSM_Hgg.ml \ omega_NMSSM.ml \ omega_NMSSM_CKM.ml \ omega_NMSSM_Hgg.ml \ omega_PSSSM.ml \ omega_Littlest.ml \ omega_Littlest_Eta.ml \ omega_Littlest_Tpar.ml \ omega_Simplest.ml \ omega_Simplest_univ.ml \ omega_Xdim.ml \ omega_GravTest.ml \ omega_NoH_rx.ml \ omega_AltH.ml \ omega_SM_rx.ml \ omega_SM_ul.ml \ omega_SSC.ml \ omega_SSC_2.ml \ omega_SSC_AltT.ml \ omega_UED.ml \ omega_WZW.ml \ omega_Zprime.ml \ omega_Zprime_VM.ml \ omega_Threeshl.ml \ omega_Threeshl_nohf.ml \ omega_HSExt.ml \ omega_HSExt_VM.ml \ omega_Template.ml \ omega_SYM.ml \ omega_UFO.ml ### Not ready for primetime yet!!! # omega_UFO_Majorana.ml OMEGA_CORE_CMO = $(OMEGA_CORE_ML:.ml=.cmo) OMEGA_CORE_CMX = $(OMEGA_CORE_ML:.ml=.cmx) OMEGA_TARGETS_CMO = $(OMEGA_TARGETLIB_ML:.ml=.cmo) OMEGA_TARGETS_CMX = $(OMEGA_TARGETLIB_ML:.ml=.cmx) OMEGA_MODELS_CMO = $(OMEGA_MODELLIB_ML:.ml=.cmo) OMEGA_MODELS_CMX = $(OMEGA_MODELLIB_ML:.ml=.cmx) OMEGA_APPLICATIONS_CMO = $(OMEGA_APPLICATIONS_ML:.ml=.cmo) OMEGA_APPLICATIONS_CMX = $(OMEGA_APPLICATIONS_ML:.ml=.cmx) OMEGA_APPLICATIONS_BYTECODE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT)) OMEGA_APPLICATIONS_NATIVE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT)) OMEGA_CACHES = $(OMEGA_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX)) OMEGA_MINIMAL_APPLICATIONS_BYTECODE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT)) OMEGA_MINIMAL_APPLICATIONS_NATIVE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT)) OMEGA_MINIMAL_CACHES = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX)) # Only primary sources, excluding generated parsers and lexers # (used for dependency generation) OMEGA_ML_PRIMARY = \ $(OMEGA_CORE_ML_PRIMARY) \ $(OMEGA_MODELLIB_ML) \ $(OMEGA_TARGETLIB_ML) \ $(OMEGA_APPLICATIONS_ML) OMEGA_MLI_PRIMARY = \ $(OMEGA_CORE_MLI_PRIMARY) \ $(OMEGA_MODELLIB_MLI) \ $(OMEGA_TARGETLIB_MLI) OMEGA_CAML_PRIMARY = $(OMEGA_ML_PRIMARY) $(OMEGA_MLI_PRIMARY) $(OMEGA_MLL) $(OMEGA_MLY) # All sources, including generated parsers and lexers # (used for linking and distribution) OMEGA_ML = \ $(OMEGA_CORE_ML) \ $(OMEGA_MODELLIB_ML) \ $(OMEGA_TARGETLIB_ML) \ $(OMEGA_APPLICATIONS_ML) OMEGA_MLI = \ $(OMEGA_CORE_MLI) \ $(OMEGA_MODELLIB_MLI) \ $(OMEGA_TARGETLIB_MLI) OMEGA_CAML = $(OMEGA_ML) $(OMEGA_MLI) $(OMEGA_MLL) $(OMEGA_MLY) $(OMEGA_DERIVED_CAML) ######################################################################## # # Fortran 90/95/2003 sources # ######################################################################## AM_FCFLAGS = ## Profiling if FC_USE_PROFILING AM_FCFLAGS += $(FCFLAGS_PROFILING) endif ## OpenMP if FC_USE_OPENMP AM_FCFLAGS += $(FCFLAGS_OPENMP) endif KINDS_F90 = kinds.f90 CONSTANTS_F90 = constants.f90 STRINGS_F90 = iso_varying_string.f90 OMEGA_PARAMETERS_F90 = # omega_parameters.f90 omega_parameters_madgraph.f90 OMEGALIB_DERIVED_F90 = \ omega_spinors.f90 omega_bispinors.f90 omega_vectors.f90 \ omega_vectorspinors.f90 omega_tensors.f90 \ omega_couplings.f90 omega_spinor_couplings.f90 omega_bispinor_couplings.f90 \ omega_polarizations.f90 omega_polarizations_madgraph.f90 \ omega_tensor_polarizations.f90 omega_vspinor_polarizations.f90 \ omega_color.f90 omega_utils.f90 \ omega95.f90 omega95_bispinors.f90 omegavm95.f90 OMEGALIB_F90 = \ $(CONSTANTS_F90) $(STRINGS_F90) \ $(OMEGALIB_DERIVED_F90) \ $(OMEGA_PARAMETERS_F90) OMEGALIB_MOD = $(KINDS_F90:.f90=.mod) $(OMEGALIB_F90:.f90=.mod) ######################################################################## ## The End. ######################################################################## Index: trunk/omega/src/algebra.ml =================================================================== --- trunk/omega/src/algebra.ml (revision 8305) +++ trunk/omega/src/algebra.ml (revision 8306) @@ -1,704 +1,708 @@ (* algebra.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + module type Test = sig val suite : OUnit.test end (* The terms will be small and there's no need to be fancy and/or efficient. It's more important to have a unique representation. *) module PM = Pmap.List (* \thocwmodulesection{Coefficients} *) (* For our algebra, we need coefficient rings. *) module type CRing = sig type t val null : t val unit : t val mul : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val to_string : t -> string end (* And rational numbers provide a particularly important example: *) module type Rational = sig include CRing val is_null : t -> bool val is_unit : t -> bool val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int end (* \thocwmodulesection{Naive Rational Arithmetic} *) (* \begin{dubious} This \emph{is} dangerous and will overflow even for simple applications. The production code will have to be linked to a library for large integer arithmetic. \end{dubious} *) (* Anyway, here's Euclid's algorithm: *) let rec gcd i1 i2 = if i2 = 0 then abs i1 else gcd i2 (i1 mod i2) let lcm i1 i2 = (i1 / gcd i1 i2) * i2 module Small_Rational : Rational = struct type t = int * int let is_null (n, _) = (n = 0) let is_unit (n, d) = (n <> 0) && (n = d) let is_positive (n, d) = n * d > 0 let is_negative (n, d) = n * d < 0 let is_integer (n, d) = (gcd n d = d) let null = (0, 1) let unit = (1, 1) let make n d = let c = gcd n d in (n / c, d / c) let abs (n, d) = (abs n, abs d) let inv (n, d) = (d, n) let mul (n1, d1) (n2, d2) = make (n1 * n2) (d1 * d2) let div q1 q2 = mul q1 (inv q2) let add (n1, d1) (n2, d2) = make (n1 * d2 + n2 * d1) (d1 * d2) let sub (n1, d1) (n2, d2) = make (n1 * d2 - n2 * d1) (d1 * d2) let neg (n, d) = (- n, d) let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let sum qs = List.fold_right add qs null let to_ratio (n, d) = if d < 0 then (-n, -d) else (n, d) let to_float (n, d) = float n /. float d let to_string (n, d) = if d = 1 then Printf.sprintf "%d" n else let n, d = to_ratio (n, d) in Printf.sprintf "(%d/%d)" n d let to_integer (n, d) = if is_integer (n, d) then n else invalid_arg "Algebra.Small_Rational.to_integer" end module Q = Small_Rational (* \thocwmodulesection{Rational Complex Numbers} *) module type QComplex = sig type q type t val make : q -> q -> t val null : t val one : t val real : t -> q val imag : t -> q val conj : t -> t val neg : t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t val inv : t -> t end module QComplex (Q : Rational) : QComplex with type q = Q.t = struct type q = Q.t type t = { re : q; im : q } let make re im = { re; im } let null = { re = Q.null; im = Q.null } let one = { re = Q.unit; im = Q.null } let real z = z.re let imag z = z.im let conj z = { re = z.re; im = Q.neg z.im } let neg z = { re = Q.neg z.re; im = Q.neg z.im } let add z1 z2 = { re = Q.add z1.re z2.re; im = Q.add z1.im z2.im } let sub z1 z2 = { re = Q.sub z1.re z2.re; im = Q.sub z1.im z2.im } (* Save one multiplication with respect to the standard formula \begin{equation} (x+iy)(u+iv) = \lbrack xu-yv\rbrack + i\lbrack(x+u)(y+v)-xu-yv\rbrack\, \end{equation} at the expense of one addition and two subtractions. *) let mul z1 z2 = let re12 = Q.mul z1.re z2.re and im12 = Q.mul z1.im z2.im in { re = Q.sub re12 im12; im = Q.sub (Q.sub (Q.mul (Q.add z1.re z1.im) (Q.add z2.re z2.im)) re12) im12 } let inv z = let modulus = Q.add (Q.mul z.re z.re) (Q.mul z.im z.im) in { re = Q.div z.re modulus; im = Q.div (Q.neg z.im) modulus } end module QC = QComplex(Q) (* \thocwmodulesection{Laurent Polynomials} *) module type Laurent = sig type c type t val null : t val unit : t val is_null : t -> bool val atom : c -> int -> t val const : c -> t val scale : c -> t -> t val add : t -> t -> t val diff : t -> t -> t val sum : t list -> t val mul : t -> t -> t val product : t list -> t val pow : int -> t -> t val eval : c -> t -> c val to_string : string -> t -> string val compare : t -> t -> int val pp : Format.formatter -> t -> unit module Test : Test end module Laurent : Laurent with type c = QC.t = struct module IMap = Map.Make (struct type t = int let compare i1 i2 = - Pervasives.compare i2 i1 + pcompare i2 i1 end) type c = QC.t let qc_minus_one = QC.neg QC.one type t = c IMap.t let null = IMap.empty let is_null l = IMap.is_empty l let atom qc n = if qc = QC.null then null else IMap.singleton n qc let const z = atom z 0 let unit = const QC.one let add1 n qc l = try let qc' = QC.add qc (IMap.find n l) in if qc' = QC.null then IMap.remove n l else IMap.add n qc' l with | Not_found -> IMap.add n qc l let add l1 l2 = IMap.fold add1 l1 l2 let sum = function | [] -> null | [l] -> l | l :: l_list -> List.fold_left add l l_list let scale qc l = IMap.map (QC.mul qc) l let diff l1 l2 = add l1 (scale qc_minus_one l2) (* cf.~[Product.fold2_rev] *) let fold2 f l1 l2 acc = IMap.fold (fun n1 qc1 acc1 -> IMap.fold (fun n2 qc2 acc2 -> f n1 qc1 n2 qc2 acc2) l2 acc1) l1 acc let mul l1 l2 = fold2 (fun n1 qc1 n2 qc2 acc -> add1 (n1 + n2) (QC.mul qc1 qc2) acc) l1 l2 null let product = function | [] -> unit | [l] -> l | l :: l_list -> List.fold_left mul l l_list let poly_pow multiply one inverse n x = let rec pow' i x' acc = if i < 1 then acc else pow' (pred i) x' (multiply x' acc) in if n < 0 then let x' = inverse x in pow' (pred (-n)) x' x' else if n = 0 then one else pow' (pred n) x x let qc_pow n z = poly_pow QC.mul QC.one QC.inv n z let pow n l = poly_pow mul unit (fun _ -> invalid_arg "Algebra.Laurent.pow") n l let q_to_string q = (if Q.is_positive q then "+" else "-") ^ Q.to_string (Q.abs q) let qc_to_string z = let r = QC.real z and i = QC.imag z in if Q.is_null i then q_to_string r else if Q.is_null r then if Q.is_unit i then "+I" else if Q.is_unit (Q.neg i) then "-I" else q_to_string i ^ "*I" else Printf.sprintf "(%s%s*I)" (Q.to_string r) (q_to_string i) let to_string1 name (n, qc) = if n = 0 then qc_to_string qc else if n = 1 then if qc = QC.one then name else if qc = qc_minus_one then "-" ^ name else Printf.sprintf "%s*%s" (qc_to_string qc) name else if n = -1 then Printf.sprintf "%s/%s" (qc_to_string qc) name else if n > 1 then if qc = QC.one then Printf.sprintf "%s^%d" name n else if qc = qc_minus_one then Printf.sprintf "-%s^%d" name n else Printf.sprintf "%s*%s^%d" (qc_to_string qc) name n else Printf.sprintf "%s/%s^%d" (qc_to_string qc) name (-n) let to_string name l = match IMap.bindings l with | [] -> "0" | l -> String.concat "" (List.map (to_string1 name) l) let pp fmt l = Format.fprintf fmt "%s" (to_string "N" l) let eval v l = IMap.fold (fun n qc acc -> QC.add (QC.mul qc (qc_pow n v)) acc) l QC.null let compare l1 l2 = - Pervasives.compare - (List.sort Pervasives.compare (IMap.bindings l1)) - (List.sort Pervasives.compare (IMap.bindings l2)) + pcompare + (List.sort pcompare (IMap.bindings l1)) + (List.sort pcompare (IMap.bindings l2)) let compare l1 l2 = - IMap.compare Pervasives.compare l1 l2 + IMap.compare pcompare l1 l2 module Test = struct open OUnit let equal l1 l2 = compare l1 l2 = 0 let assert_equal_laurent l1 l2 = assert_equal ~printer:(to_string "N") ~cmp:equal l1 l2 let suite_mul = "mul" >::: [ "(1+N)(1-N)=1-N^2" >:: (fun () -> assert_equal_laurent (sum [unit; atom (QC.neg QC.one) 2]) (product [sum [unit; atom QC.one 1]; sum [unit; atom (QC.neg QC.one) 1]])); "(1+N)(1-1/N)=N-1/N" >:: (fun () -> assert_equal_laurent (sum [atom QC.one 1; atom (QC.neg QC.one) (-1)]) (product [sum [unit; atom QC.one 1]; sum [unit; atom (QC.neg QC.one) (-1)]])); ] let suite = "Algebra.Laurent" >::: [suite_mul] end end (* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *) (* The tensor algebra will be spanned by an abelian monoid: *) module type Term = sig type 'a t val unit : unit -> 'a t val is_unit : 'a t -> bool val atom : 'a -> 'a t val power : int -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list val product : 'a t list -> 'a t val atoms : 'a t -> 'a list end module type Ring = sig module C : Rational type 'a t val null : unit -> 'a t val unit : unit -> 'a t val is_null : 'a t -> bool val is_unit : 'a t -> bool val atom : 'a -> 'a t val scale : C.t -> 'a t -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val neg : 'a t -> 'a t val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *) val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *) val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list val sum : 'a t list -> 'a t val product : 'a t list -> 'a t val atoms : 'a t -> 'a list val to_string : ('a -> string) -> 'a t -> string end module type Linear = sig module C : Ring type ('a, 'c) t val null : unit -> ('a, 'c) t val atom : 'a -> ('a, 'c) t val singleton : 'c C.t -> 'a -> ('a, 'c) t val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t val sum : ('a, 'c) t list -> ('a, 'c) t val atoms : ('a, 'c) t -> 'a list * 'c list val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string end module Term : Term = struct module M = PM type 'a t = ('a, int) M.t let unit () = M.empty let is_unit = M.is_empty let atom f = M.singleton f 1 let power p x = M.map (( * ) p) x let insert1 binop f p term = let p' = binop (try M.find compare f term with Not_found -> 0) p in if p' = 0 then M.remove compare f term else M.add compare f p' term let mul1 f p term = insert1 (+) f p term let mul x y = M.fold mul1 x y let map f term = M.fold (fun t -> mul1 (f t)) term M.empty let to_string fmt term = String.concat "*" (M.fold (fun f p acc -> (if p = 0 then "1" else if p = 1 then fmt f else "[" ^ fmt f ^ "]^" ^ string_of_int p) :: acc) term []) let derive derive1 x = M.fold (fun f p dx -> if p <> 0 then match derive1 f with | Some df -> (df, p, mul1 f (pred p) (M.remove compare f x)) :: dx | None -> dx else dx) x [] let product factors = List.fold_left mul (unit ()) factors let atoms t = List.map fst (PM.elements t) end module Make_Ring (C : Rational) (T : Term) : Ring = struct module C = C let one = C.unit module M = PM type 'a t = ('a T.t, C.t) M.t let null () = M.empty let is_null = M.is_empty let power t p = M.singleton t p let unit () = power (T.unit ()) one let is_unit t = unit () = t (* \begin{dubious} The following should be correct too, but produces to many false positives instead! What's going on? \end{dubious} *) let broken__is_unit t = match M.elements t with | [(t, p)] -> T.is_unit t || C.is_null p | _ -> false let atom t = power (T.atom t) one let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x (* One might be tempted to use [Product.outer_self M.fold] instead, but this would require us to combine~[tx] and~[cx] to~[(tx, cx)]. *) let fold2 f x y = M.fold (fun tx cx -> M.fold (f tx cx) y) x let mul x y = fold2 (fun tx cx ty cy -> insert1 C.add (T.mul tx ty) (C.mul cx cy)) x y (null ()) let neg x = sub (null ()) x let neg x = scale (C.neg C.unit) x (* Multiply the [derivatives] by [c] and add the result to [dx]. *) let add_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> add (mul df (power dt_t (C.mul c (C.make dt_c 1)))) acc) dx derivatives let derive_inner derive1 x = M.fold (fun t -> add_derivatives (T.derive (fun f -> Some (derive1 f)) t)) x (null ()) let derive_inner' derive1 x = M.fold (fun t -> add_derivatives (T.derive derive1 t)) x (null ()) let collect_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> (df, power dt_t (C.mul c (C.make dt_c 1))) :: acc) dx derivatives let derive_outer derive1 x = M.fold (fun t -> collect_derivatives (T.derive derive1 t)) x [] let sum terms = List.fold_left add (null ()) terms let product factors = List.fold_left mul (unit ()) factors let atoms t = ThoList.uniq (List.sort compare (ThoList.flatmap (fun (t, _) -> T.atoms t) (PM.elements t))) let to_string fmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then T.to_string fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ T.to_string fmt t ^ ")") :: acc else (C.to_string c ^ "*[" ^ T.to_string fmt t ^ "]") :: acc) sum []) ^ ")" end module Make_Linear (C : Ring) : Linear with module C = C = struct module C = C module M = PM type ('a, 'c) t = ('a, 'c C.t) M.t let null () = M.empty let is_null = M.is_empty let atom a = M.singleton a (C.unit ()) let singleton c a = M.singleton a c let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null ()) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x let map f t = M.fold (fun a c -> add (f a c)) t M.empty let sum terms = List.fold_left add (null ()) terms let linear terms = List.fold_left (fun acc (a, c) -> add (scale c a) acc) (null ()) terms let partial derive t = let d t' = let dt' = derive t' in if is_null dt' then None else Some dt' in linear (C.derive_outer d t) let atoms t = let a, c = List.split (PM.elements t) in (a, ThoList.uniq (List.sort compare (ThoList.flatmap C.atoms c))) let to_string fmt cfmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ fmt t ^ ")") :: acc else (C.to_string cfmt c ^ "*" ^ fmt t) :: acc) sum []) ^ ")" end (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/colorize.ml =================================================================== --- trunk/omega/src/colorize.ml (revision 8305) +++ trunk/omega/src/colorize.ml (revision 8306) @@ -1,1836 +1,1839 @@ (* colorize.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla So Young Shim WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Auxiliary functions} *) (* \thocwmodulesubsection{Exceptions} *) let incomplete s = failwith ("Colorize." ^ s ^ " not done yet!") let invalid s = invalid_arg ("Colorize." ^ s ^ " must not be evaluated!") let impossible s = invalid_arg ("Colorize." ^ s ^ " can't happen! (but just did ...)") let mismatch s = invalid_arg ("Colorize." ^ s ^ " mismatch of representations!") let su0 s = invalid_arg ("Colorize." ^ s ^ ": found SU(0)!") let colored_vertex s = invalid_arg ("Colorize." ^ s ^ ": colored vertex!") let baryonic_vertex s = invalid_arg ("Colorize." ^ s ^ ": baryonic (i.e. eps_ijk) vertices not supported yet!") let color_flow_ambiguous s = invalid_arg ("Colorize." ^ s ^ ": ambiguous color flow!") let color_flow_of_string s = let c = int_of_string s in if c < 1 then invalid_arg ("Colorize." ^ s ^ ": color flow # < 1!") else c (* \thocwmodulesubsection{Multiplying Vertices by a Constant Factor} *) module Q = Algebra.Q module QC = Algebra.QC let of_int n = QC.make (Q.make n 1) Q.null let integer z = if Q.is_null (QC.imag z) then let x = QC.real z in try Some (Q.to_integer x) with | _ -> None else None let mult_vertex3 x v = let open Coupling in match v with | FBF (c, fb, coup, f) -> FBF ((x * c), fb, coup, f) | PBP (c, fb, coup, f) -> PBP ((x * c), fb, coup, f) | BBB (c, fb, coup, f) -> BBB ((x * c), fb, coup, f) | GBG (c, fb, coup, f) -> GBG ((x * c), fb, coup, f) | Gauge_Gauge_Gauge c -> Gauge_Gauge_Gauge (x * c) | I_Gauge_Gauge_Gauge c -> I_Gauge_Gauge_Gauge (x * c) | Aux_Gauge_Gauge c -> Aux_Gauge_Gauge (x * c) | Scalar_Vector_Vector c -> Scalar_Vector_Vector (x * c) | Aux_Vector_Vector c -> Aux_Vector_Vector (x * c) | Aux_Scalar_Vector c -> Aux_Scalar_Vector (x * c) | Scalar_Scalar_Scalar c -> Scalar_Scalar_Scalar (x * c) | Aux_Scalar_Scalar c -> Aux_Scalar_Scalar (x * c) | Vector_Scalar_Scalar c -> Vector_Scalar_Scalar (x * c) | Graviton_Scalar_Scalar c -> Graviton_Scalar_Scalar (x * c) | Graviton_Vector_Vector c -> Graviton_Vector_Vector (x * c) | Graviton_Spinor_Spinor c -> Graviton_Spinor_Spinor (x * c) | Dim4_Vector_Vector_Vector_T c -> Dim4_Vector_Vector_Vector_T (x * c) | Dim4_Vector_Vector_Vector_L c -> Dim4_Vector_Vector_Vector_L (x * c) | Dim4_Vector_Vector_Vector_T5 c -> Dim4_Vector_Vector_Vector_T5 (x * c) | Dim4_Vector_Vector_Vector_L5 c -> Dim4_Vector_Vector_Vector_L5 (x * c) | Dim6_Gauge_Gauge_Gauge c -> Dim6_Gauge_Gauge_Gauge (x * c) | Dim6_Gauge_Gauge_Gauge_5 c -> Dim6_Gauge_Gauge_Gauge_5 (x * c) | Aux_DScalar_DScalar c -> Aux_DScalar_DScalar (x * c) | Aux_Vector_DScalar c -> Aux_Vector_DScalar (x * c) | Dim5_Scalar_Gauge2 c -> Dim5_Scalar_Gauge2 (x * c) | Dim5_Scalar_Gauge2_Skew c -> Dim5_Scalar_Gauge2_Skew (x * c) | Dim5_Scalar_Vector_Vector_T c -> Dim5_Scalar_Vector_Vector_T (x * c) | Dim5_Scalar_Vector_Vector_U c -> Dim5_Scalar_Vector_Vector_U (x * c) | Dim5_Scalar_Vector_Vector_TU c -> Dim5_Scalar_Vector_Vector_TU (x * c) | Dim5_Scalar_Scalar2 c -> Dim5_Scalar_Scalar2 (x * c) | Scalar_Vector_Vector_t c -> Scalar_Vector_Vector_t (x * c) | Dim6_Vector_Vector_Vector_T c -> Dim6_Vector_Vector_Vector_T (x * c) | Tensor_2_Vector_Vector c -> Tensor_2_Vector_Vector (x * c) | Tensor_2_Vector_Vector_cf c -> Tensor_2_Vector_Vector_cf (x * c) | Tensor_2_Scalar_Scalar c -> Tensor_2_Scalar_Scalar (x * c) | Tensor_2_Scalar_Scalar_cf c -> Tensor_2_Scalar_Scalar_cf (x * c) | Tensor_2_Vector_Vector_1 c -> Tensor_2_Vector_Vector_1 (x * c) | Tensor_2_Vector_Vector_t c -> Tensor_2_Vector_Vector_t (x * c) | Dim5_Tensor_2_Vector_Vector_1 c -> Dim5_Tensor_2_Vector_Vector_1 (x * c) | Dim5_Tensor_2_Vector_Vector_2 c -> Dim5_Tensor_2_Vector_Vector_2 (x * c) | TensorVector_Vector_Vector c -> TensorVector_Vector_Vector (x * c) | TensorVector_Vector_Vector_cf c -> TensorVector_Vector_Vector_cf (x * c) | TensorVector_Scalar_Scalar c -> TensorVector_Scalar_Scalar (x * c) | TensorVector_Scalar_Scalar_cf c -> TensorVector_Scalar_Scalar_cf (x * c) | TensorScalar_Vector_Vector c -> TensorScalar_Vector_Vector (x * c) | TensorScalar_Vector_Vector_cf c -> TensorScalar_Vector_Vector_cf (x * c) | TensorScalar_Scalar_Scalar c -> TensorScalar_Scalar_Scalar (x * c) | TensorScalar_Scalar_Scalar_cf c -> TensorScalar_Scalar_Scalar_cf (x * c) | Dim7_Tensor_2_Vector_Vector_T c -> Dim7_Tensor_2_Vector_Vector_T (x * c) | Dim6_Scalar_Vector_Vector_D c -> Dim6_Scalar_Vector_Vector_D (x * c) | Dim6_Scalar_Vector_Vector_DP c -> Dim6_Scalar_Vector_Vector_DP (x * c) | Dim6_HAZ_D c -> Dim6_HAZ_D (x * c) | Dim6_HAZ_DP c -> Dim6_HAZ_DP (x * c) | Gauge_Gauge_Gauge_i c -> Gauge_Gauge_Gauge_i (x * c) | Dim6_GGG c -> Dim6_GGG (x * c) | Dim6_AWW_DP c -> Dim6_AWW_DP (x *c) | Dim6_AWW_DW c -> Dim6_AWW_DW (x * c) | Dim6_Gauge_Gauge_Gauge_i c -> Dim6_Gauge_Gauge_Gauge_i (x * c) | Dim6_HHH c -> Dim6_HHH (x * c) | Dim6_WWZ_DPWDW c -> Dim6_WWZ_DPWDW (x * c) | Dim6_WWZ_DW c -> Dim6_WWZ_DW (x * c) | Dim6_WWZ_D c -> Dim6_WWZ_D (x * c) let cmult_vertex3 z v = match integer z with | None -> invalid_arg "cmult_vertex3" | Some x -> mult_vertex3 x v let mult_vertex4 x v = let open Coupling in match v with | Scalar4 c -> Scalar4 (x * c) | Scalar2_Vector2 c -> Scalar2_Vector2 (x * c) | Vector4 ic4_list -> Vector4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | DScalar4 ic4_list -> DScalar4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | DScalar2_Vector2 ic4_list -> DScalar2_Vector2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | GBBG (c, fb, b2, f) -> GBBG ((x * c), fb, b2, f) | Vector4_K_Matrix_tho (c, ic4_list) -> Vector4_K_Matrix_tho ((x * c), ic4_list) | Vector4_K_Matrix_jr (c, ch2_list) -> Vector4_K_Matrix_jr ((x * c), ch2_list) | Vector4_K_Matrix_cf_t0 (c, ch2_list) -> Vector4_K_Matrix_cf_t0 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t1 (c, ch2_list) -> Vector4_K_Matrix_cf_t1 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t2 (c, ch2_list) -> Vector4_K_Matrix_cf_t2 ((x * c), ch2_list) | Vector4_K_Matrix_cf_t_rsi (c, ch2_list) -> Vector4_K_Matrix_cf_t_rsi ((x * c), ch2_list) | Vector4_K_Matrix_cf_m0 (c, ch2_list) -> Vector4_K_Matrix_cf_m0 ((x * c), ch2_list) | Vector4_K_Matrix_cf_m1 (c, ch2_list) -> Vector4_K_Matrix_cf_m1 ((x * c), ch2_list) | Vector4_K_Matrix_cf_m7 (c, ch2_list) -> Vector4_K_Matrix_cf_m7 ((x * c), ch2_list) | DScalar2_Vector2_K_Matrix_ms (c, ch2_list) -> DScalar2_Vector2_K_Matrix_ms ((x * c), ch2_list) | DScalar2_Vector2_m_0_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_0_K_Matrix_cf ((x * c), ch2_list) | DScalar2_Vector2_m_1_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_1_K_Matrix_cf ((x * c), ch2_list) | DScalar2_Vector2_m_7_K_Matrix_cf (c, ch2_list) -> DScalar2_Vector2_m_7_K_Matrix_cf ((x * c), ch2_list) | DScalar4_K_Matrix_ms (c, ch2_list) -> DScalar4_K_Matrix_ms ((x * c), ch2_list) | Dim8_Scalar2_Vector2_1 c -> Dim8_Scalar2_Vector2_1 (x * c) | Dim8_Scalar2_Vector2_2 c -> Dim8_Scalar2_Vector2_1 (x * c) | Dim8_Scalar2_Vector2_m_0 c -> Dim8_Scalar2_Vector2_m_0 (x * c) | Dim8_Scalar2_Vector2_m_1 c -> Dim8_Scalar2_Vector2_m_1 (x * c) | Dim8_Scalar2_Vector2_m_7 c -> Dim8_Scalar2_Vector2_m_7 (x * c) | Dim8_Scalar4 c -> Dim8_Scalar4 (x * c) | Dim8_Vector4_t_0 ic4_list -> Dim8_Vector4_t_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_t_1 ic4_list -> Dim8_Vector4_t_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_t_2 ic4_list -> Dim8_Vector4_t_2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_0 ic4_list -> Dim8_Vector4_m_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_1 ic4_list -> Dim8_Vector4_m_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim8_Vector4_m_7 ic4_list -> Dim8_Vector4_m_7 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list) | Dim6_H4_P2 c -> Dim6_H4_P2 (x * c) | Dim6_AHWW_DPB c -> Dim6_AHWW_DPB (x * c) | Dim6_AHWW_DPW c -> Dim6_AHWW_DPW (x * c) | Dim6_AHWW_DW c -> Dim6_AHWW_DW (x * c) | Dim6_Vector4_DW c -> Dim6_Vector4_DW (x * c) | Dim6_Vector4_W c -> Dim6_Vector4_W (x * c) | Dim6_Scalar2_Vector2_PB c -> Dim6_Scalar2_Vector2_PB (x * c) | Dim6_Scalar2_Vector2_D c -> Dim6_Scalar2_Vector2_D (x * c) | Dim6_Scalar2_Vector2_DP c -> Dim6_Scalar2_Vector2_DP (x * c) | Dim6_HHZZ_T c -> Dim6_HHZZ_T (x * c) | Dim6_HWWZ_DW c -> Dim6_HWWZ_DW (x * c) | Dim6_HWWZ_DPB c -> Dim6_HWWZ_DPB (x * c) | Dim6_HWWZ_DDPW c -> Dim6_HWWZ_DDPW (x * c) | Dim6_HWWZ_DPW c -> Dim6_HWWZ_DPW (x * c) | Dim6_AHHZ_D c -> Dim6_AHHZ_D (x * c) | Dim6_AHHZ_DP c -> Dim6_AHHZ_DP (x * c) | Dim6_AHHZ_PB c -> Dim6_AHHZ_PB (x * c) let cmult_vertex4 z v = match integer z with | None -> invalid_arg "cmult_vertex4" | Some x -> mult_vertex4 x v let mult_vertexn x = function | _ -> incomplete "mult_vertexn" let cmult_vertexn z v = let open Coupling in match v with | UFO (c, v, s, fl, col) -> UFO (QC.mul z c, v, s, fl, col) let mult_vertex x v = let open Coupling in match v with | V3 (v, fuse, c) -> V3 (mult_vertex3 x v, fuse, c) | V4 (v, fuse, c) -> V4 (mult_vertex4 x v, fuse, c) | Vn (v, fuse, c) -> Vn (mult_vertexn x v, fuse, c) let cmult_vertex z v = let open Coupling in match v with | V3 (v, fuse, c) -> V3 (cmult_vertex3 z v, fuse, c) | V4 (v, fuse, c) -> V4 (cmult_vertex4 z v, fuse, c) | Vn (v, fuse, c) -> Vn (cmult_vertexn z v, fuse, c) (* \thocwmodulesection{Flavors Adorned with Colorflows} *) module Flavor (M : Model.T) = struct type cf_in = int type cf_out = int type t = | White of M.flavor | CF_in of M.flavor * cf_in | CF_out of M.flavor * cf_out | CF_io of M.flavor * cf_in * cf_out | CF_aux of M.flavor let flavor_sans_color = function | White f -> f | CF_in (f, _) -> f | CF_out (f, _) -> f | CF_io (f, _, _) -> f | CF_aux f -> f let pullback f arg1 = f (flavor_sans_color arg1) end (* \thocwmodulesection{The Legacy Implementation} *) module Legacy_Implementation (M : Model.T) = struct module C = Color module Colored_Flavor = Flavor(M) open Colored_Flavor open Coupling let nc = M.nc (* \thocwmodulesubsection{Auxiliary functions} *) (* Below, we will need to permute Lorentz structures. The following permutes the three possible contractions of four vectors. We permute the first three indices, as they correspond to the particles entering the fusion. *) type permutation4 = | P123 | P231 | P312 | P213 | P321 | P132 let permute_contract4 = function | P123 -> begin function | C_12_34 -> C_12_34 | C_13_42 -> C_13_42 | C_14_23 -> C_14_23 end | P231 -> begin function | C_12_34 -> C_14_23 | C_13_42 -> C_12_34 | C_14_23 -> C_13_42 end | P312 -> begin function | C_12_34 -> C_13_42 | C_13_42 -> C_14_23 | C_14_23 -> C_12_34 end | P213 -> begin function | C_12_34 -> C_12_34 | C_13_42 -> C_14_23 | C_14_23 -> C_13_42 end | P321 -> begin function | C_12_34 -> C_14_23 | C_13_42 -> C_13_42 | C_14_23 -> C_12_34 end | P132 -> begin function | C_12_34 -> C_13_42 | C_13_42 -> C_12_34 | C_14_23 -> C_14_23 end let permute_contract4_list perm ic4_list = List.map (fun (i, c4) -> (i, permute_contract4 perm c4)) ic4_list let permute_vertex4' perm = function | Scalar4 c -> Scalar4 c | Vector4 ic4_list -> Vector4 (permute_contract4_list perm ic4_list) | Vector4_K_Matrix_jr (c, ic4_list) -> Vector4_K_Matrix_jr (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t0 (c, ic4_list) -> Vector4_K_Matrix_cf_t0 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t1 (c, ic4_list) -> Vector4_K_Matrix_cf_t1 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t2 (c, ic4_list) -> Vector4_K_Matrix_cf_t2 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_t_rsi (c, ic4_list) -> Vector4_K_Matrix_cf_t_rsi (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m0 (c, ic4_list) -> Vector4_K_Matrix_cf_m0 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m1 (c, ic4_list) -> Vector4_K_Matrix_cf_m1 (c, permute_contract4_list perm ic4_list) | Vector4_K_Matrix_cf_m7 (c, ic4_list) -> Vector4_K_Matrix_cf_m7 (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_K_Matrix_ms (c, ic4_list) -> DScalar2_Vector2_K_Matrix_ms (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_0_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_0_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_1_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_1_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar2_Vector2_m_7_K_Matrix_cf (c, ic4_list) -> DScalar2_Vector2_m_7_K_Matrix_cf (c, permute_contract4_list perm ic4_list) | DScalar4_K_Matrix_ms (c, ic4_list) -> DScalar4_K_Matrix_ms (c, permute_contract4_list perm ic4_list) | Scalar2_Vector2 c -> incomplete "permute_vertex4' Scalar2_Vector2" | DScalar4 ic4_list -> incomplete "permute_vertex4' DScalar4" | DScalar2_Vector2 ic4_list -> incomplete "permute_vertex4' DScalar2_Vector2" | GBBG (c, fb, b2, f) -> incomplete "permute_vertex4' GBBG" | Vector4_K_Matrix_tho (c, ch2_list) -> incomplete "permute_vertex4' Vector4_K_Matrix_tho" | Dim8_Scalar2_Vector2_1 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_1" | Dim8_Scalar2_Vector2_2 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_2" | Dim8_Scalar2_Vector2_m_0 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_0" | Dim8_Scalar2_Vector2_m_1 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_1" | Dim8_Scalar2_Vector2_m_7 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_7" | Dim8_Scalar4 ic4_list -> incomplete "permute_vertex4' Dim8_Scalar4" | Dim8_Vector4_t_0 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_0" | Dim8_Vector4_t_1 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_1" | Dim8_Vector4_t_2 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_t_2" | Dim8_Vector4_m_0 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_0" | Dim8_Vector4_m_1 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_1" | Dim8_Vector4_m_7 ic4_list -> incomplete "permute_vertex4' Dim8_Vector4_m_7" | Dim6_H4_P2 ic4_list -> incomplete "permute_vertex4' Dim6_H4_P2" | Dim6_AHWW_DPB ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DPB" | Dim6_AHWW_DPW ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DPW" | Dim6_AHWW_DW ic4_list -> incomplete "permute_vertex4' Dim6_AHWW_DW" | Dim6_Vector4_DW ic4_list -> incomplete "permute_vertex4' Dim6_Vector4_DW" | Dim6_Vector4_W ic4_list -> incomplete "permute_vertex4' Dim6_Vector4_W" | Dim6_Scalar2_Vector2_D ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_D" | Dim6_Scalar2_Vector2_DP ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_DP" | Dim6_Scalar2_Vector2_PB ic4_list -> incomplete "permute_vertex4' Dim6_Scalar2_Vector2_PB" | Dim6_HHZZ_T ic4_list -> incomplete "permute_vertex4' Dim6_HHZZ_T" | Dim6_HWWZ_DW ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DW" | Dim6_HWWZ_DPB ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DPB" | Dim6_HWWZ_DDPW ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DDPW" | Dim6_HWWZ_DPW ic4_list -> incomplete "permute_vertex4' Dim6_HWWZ_DPW" | Dim6_AHHZ_D ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_D" | Dim6_AHHZ_DP ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_DP" | Dim6_AHHZ_PB ic4_list -> incomplete "permute_vertex4' Dim6_AHHZ_PB" let permute_vertex4 perm = function | V3 (v, fuse, c) -> V3 (v, fuse, c) | V4 (v, fuse, c) -> V4 (permute_vertex4' perm v, fuse, c) | Vn (v, fuse, c) -> Vn (v, fuse, c) (* \thocwmodulesubsection{Cubic Vertices} *) (* \begin{dubious} The following pattern matches could eventually become quite long. The O'Caml compiler will (hopefully) optimize them aggressively (\url{http://pauillac.inria.fr/~maranget/papers/opat/}). \end{dubious} *) let colorize_fusion2 f1 f2 (f, v) = match M.color f with | C.Singlet -> begin match f1, f2 with | White _, White _ -> [White f, v] | CF_in (_, c1), CF_out (_, c2') | CF_out (_, c1), CF_in (_, c2') -> if c1 = c2' then [White f, v] else [] | CF_io (f1, c1, c1'), CF_io (f2, c2, c2') -> if c1 = c2' && c2 = c1' then [White f, v] else [] | CF_aux f1, CF_aux f2 -> [White f, mult_vertex (- (nc ())) v] | CF_aux _, CF_io _ | CF_io _, CF_aux _ -> [] | (CF_in _ | CF_out _ | CF_io _ | CF_aux _), White _ | White _, (CF_in _ | CF_out _ | CF_io _ | CF_aux _) | (CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (CF_in _ | CF_out _), (CF_io _ | CF_aux _) | CF_in _, CF_in _ | CF_out _, CF_out _ -> colored_vertex "colorize_fusion2" end | C.SUN nc1 -> begin match f1, f2 with | CF_in (_, c1), (White _ | CF_aux _) | (White _ | CF_aux _), CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), v] else colored_vertex "colorize_fusion2" | CF_out (_, c1'), (White _ | CF_aux _) | (White _ | CF_aux _), CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), v] else colored_vertex "colorize_fusion2" | CF_in (_, c1), CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_in (_, c1) -> if nc1 > 0 then begin if c1 = c2' then [CF_in (f, c2), v] else [] end else colored_vertex "colorize_fusion2" | CF_out (_, c1'), CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_out (_, c1') -> if nc1 < 0 then begin if c1' = c2 then [CF_out (f, c2'), v] else [] end else colored_vertex "colorize_fusion2" | CF_in _, CF_in _ -> if nc1 > 0 then baryonic_vertex "colorize_fusion2" else colored_vertex "colorize_fusion2" | CF_out _, CF_out _ -> if nc1 < 0 then baryonic_vertex "colorize_fusion2" else colored_vertex "colorize_fusion2" | CF_in _, CF_out _ | CF_out _, CF_in _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) -> colored_vertex "colorize_fusion2" end | C.AdjSUN _ -> begin match f1, f2 with | White _, CF_io (_, c1, c2') | CF_io (_, c1, c2'), White _ -> [CF_io (f, c1, c2'), v] | White _, CF_aux _ | CF_aux _, White _ -> [CF_aux f, mult_vertex (- (nc ())) v] | CF_in (_, c1), CF_out (_, c2') | CF_out (_, c2'), CF_in (_, c1) -> if c1 <> c2' then [CF_io (f, c1, c2'), v] else [CF_aux f, v] (* In the adjoint representation \begin{subequations} \begin{equation} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3} \fmf{gluon}{v,e1} \fmf{gluon}{v,e2} \fmf{gluon}{v,e3} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e1} \fmf{warrow_right}{v,e2} \fmf{warrow_right}{v,e3} \end{fmfgraph*}}} \,= %begin{split} g f_{a_1a_2a_3} C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3) %end{split} \end{equation} with \begin{multline} \label{eq:C123} C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3) = \\ ( 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{multline} \end{subequations} while in the color flow basis find from \begin{equation} \label{eq:f=tr(TTT)} \ii f_{a_1a_2a_3} = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right) = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right) - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \end{equation} the decomposition \begin{equation} \label{eq:fTTT} \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3} = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,. \end{equation} The resulting Feynman rule is \begin{equation} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3} \fmf{phantom}{v,e1} \fmf{phantom}{v,e2} \fmf{phantom}{v,e3} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmffreeze \fmfi{phantom_arrow}{(reverse vpath (__e1, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e1, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e1, __v) sideways -thick) join ( vpath (__e2, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e2, __v) sideways -thick) join ( vpath (__e3, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e3, __v) sideways -thick) join ( vpath (__e1, __v) sideways -thick)} \end{fmfgraph*}}} \,= \ii g \left( \delta^{i_1j_3}\delta^{i_2j_1}\delta^{i_3j_2} - \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} \right) C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3) \end{equation} *) (* \begin{dubious} We have to generalize this for cases of three particles in the adjoint that are not all gluons (gluinos, scalar octets): \begin{itemize} \item scalar-scalar-scalar \item scalar-scalar-vector \item scalar-vector-vector \item scalar-fermion-fermion \item vector-fermion-fermion \end{itemize} \end{dubious} *) (* \begin{dubious} We could use a better understanding of the signs for the gaugino-gaugino-gaugeboson couplings!!! \end{dubious} *) | CF_io (f1, c1, c1'), CF_io (f2, c2, c2') -> let phase = begin match v with | V3 (Gauge_Gauge_Gauge _, _, _) | V3 (I_Gauge_Gauge_Gauge _, _, _) | V3 (Aux_Gauge_Gauge _, _, _) -> of_int 1 | V3 (FBF (_, _, _, _), fuse2, _) -> begin match fuse2 with | F12 -> of_int 1 (* works, needs underpinning *) | F21 -> of_int (-1) (* dto. *) | F31 -> of_int 1 (* dto. *) | F32 -> of_int (-1) (* transposition of [F12] *) | F23 -> of_int 1 (* transposition of [F21] *) | F13 -> of_int (-1) (* transposition of [F12] *) end | V3 _ -> incomplete "colorize_fusion2 (V3 _)" | V4 _ -> impossible "colorize_fusion2 (V4 _)" | Vn _ -> impossible "colorize_fusion2 (Vn _)" end in if c1' = c2 then [CF_io (f, c1, c2'), cmult_vertex (QC.neg phase) v] else if c2' = c1 then [CF_io (f, c2, c1'), cmult_vertex ( phase) v] else [] | CF_aux _ , CF_io _ | CF_io _ , CF_aux _ | CF_aux _ , CF_aux _ -> [] | White _, White _ | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | CF_in _, CF_in _ | CF_out _, CF_out _ -> colored_vertex "colorize_fusion2" end (* \thocwmodulesubsection{Quartic Vertices} *) let colorize_fusion3 f1 f2 f3 (f, v) = match M.color f with | C.Singlet -> begin match f1, f2, f3 with | White _, White _, White _ -> [White f, v] | (White _ | CF_aux _), CF_in (_, c1), CF_out (_, c2') | (White _ | CF_aux _), CF_out (_, c1), CF_in (_, c2') | CF_in (_, c1), (White _ | CF_aux _), CF_out (_, c2') | CF_out (_, c1), (White _ | CF_aux _), CF_in (_, c2') | CF_in (_, c1), CF_out (_, c2'), (White _ | CF_aux _) | CF_out (_, c1), CF_in (_, c2'), (White _ | CF_aux _) -> if c1 = c2' then [White f, v] else [] | White _, CF_io (_, c1, c1'), CF_io (_, c2, c2') | CF_io (_, c1, c1'), White _, CF_io (_, c2, c2') | CF_io (_, c1, c1'), CF_io (_, c2, c2'), White _ -> if c1 = c2' && c2 = c1' then [White f, v] else [] | White _, CF_aux _, CF_aux _ | CF_aux _, White _, CF_aux _ | CF_aux _, CF_aux _, White _ -> [White f, mult_vertex (- (nc ())) v] | White _, CF_io _, CF_aux _ | White _, CF_aux _, CF_io _ | CF_io _, White _, CF_aux _ | CF_aux _, White _, CF_io _ | CF_io _, CF_aux _, White _ | CF_aux _, CF_io _, White _ -> [] | CF_io (_, c1, c1'), CF_in (_, c2), CF_out (_, c3') | CF_io (_, c1, c1'), CF_out (_, c3'), CF_in (_, c2) | CF_in (_, c2), CF_io (_, c1, c1'), CF_out (_, c3') | CF_out (_, c3'), CF_io (_, c1, c1'), CF_in (_, c2) | CF_in (_, c2), CF_out (_, c3'), CF_io (_, c1, c1') | CF_out (_, c3'), CF_in (_, c2), CF_io (_, c1, c1') -> if c1 = c3' && c1' = c2 then [White f, v] else [] | CF_io (_, c1, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') -> if c1' = c2 && c2' = c3 && c3' = c1 then [White f, mult_vertex (-1) v] else if c1' = c3 && c2' = c1 && c3' = c2 then [White f, mult_vertex ( 1) v] else [] | CF_io _, CF_io _, CF_aux _ | CF_io _, CF_aux _, CF_io _ | CF_aux _, CF_io _, CF_io _ | CF_io _, CF_aux _, CF_aux _ | CF_aux _, CF_io _, CF_aux _ | CF_aux _, CF_aux _, CF_io _ | CF_aux _, CF_aux _, CF_aux _ -> [] | CF_in _, CF_in _, CF_in _ | CF_out _, CF_out _, CF_out _ -> baryonic_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_out _ | CF_in _, CF_out _, CF_in _ | CF_out _, CF_in _, CF_in _ | CF_in _, CF_out _, CF_out _ | CF_out _, CF_in _, CF_out _ | CF_out _, CF_out _, CF_in _ | White _, White _, (CF_io _ | CF_aux _) | White _, (CF_io _ | CF_aux _), White _ | (CF_io _ | CF_aux _), White _, White _ | (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _ | CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _ | CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _ | CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _ | CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" end | C.SUN nc1 -> begin match f1, f2, f3 with | CF_in (_, c1), CF_io (_, c2, c2'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_in (_, c1), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_in (_, c1) -> if nc1 > 0 then if c1 = c2' && c2 = c3' then [CF_in (f, c3), v] else if c1 = c3' && c3 = c2' then [CF_in (f, c2), v] else [] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_out (_, c1'), CF_io (_, c3, c3') | CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_out (_, c1') -> if nc1 < 0 then if c1' = c2 && c2' = c3 then [CF_out (f, c3'), v] else if c1' = c3 && c3' = c2 then [CF_out (f, c2'), v] else [] else colored_vertex "colorize_fusion3" | CF_aux _, CF_in (_, c1), CF_io (_, c2, c2') | CF_aux _, CF_io (_, c2, c2'), CF_in (_, c1) | CF_in (_, c1), CF_aux _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_aux _, CF_in (_, c1) | CF_in (_, c1), CF_io (_, c2, c2'), CF_aux _ | CF_io (_, c2, c2'), CF_in (_, c1), CF_aux _ -> if nc1 > 0 then if c1 = c2' then [CF_in (f, c2), mult_vertex ( 2) v] else [] else colored_vertex "colorize_fusion3" | CF_aux _, CF_out (_, c1'), CF_io (_, c2, c2') | CF_aux _, CF_io (_, c2, c2'), CF_out (_, c1') | CF_out (_, c1'), CF_aux _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), CF_aux _, CF_out (_, c1') | CF_out (_, c1'), CF_io (_, c2, c2'), CF_aux _ | CF_io (_, c2, c2'), CF_out (_, c1'), CF_aux _ -> if nc1 < 0 then if c1' = c2 then [CF_out (f, c2'), mult_vertex ( 2) v] else [] else colored_vertex "colorize_fusion3" | White _, CF_in (_, c1), CF_io (_, c2, c2') | White _, CF_io (_, c2, c2'), CF_in (_, c1) | CF_in (_, c1), White _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), White _, CF_in (_, c1) | CF_in (_, c1), CF_io (_, c2, c2'), White _ | CF_io (_, c2, c2'), CF_in (_, c1), White _ -> if nc1 > 0 then if c1 = c2' then [CF_in (f, c2), v] else [] else colored_vertex "colorize_fusion3" | White _, CF_out (_, c1'), CF_io (_, c2, c2') | White _, CF_io (_, c2, c2'), CF_out (_, c1') | CF_out (_, c1'), White _, CF_io (_, c2, c2') | CF_io (_, c2, c2'), White _, CF_out (_, c1') | CF_out (_, c1'), CF_io (_, c2, c2'), White _ | CF_io (_, c2, c2'), CF_out (_, c1'), White _ -> if nc1 < 0 then if c2 = c1' then [CF_out (f, c2'), v] else [] else colored_vertex "colorize_fusion3" | CF_in (_, c1), CF_aux _, CF_aux _ | CF_aux _, CF_in (_, c1), CF_aux _ | CF_aux _, CF_aux _, CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), mult_vertex ( 2) v] else colored_vertex "colorize_fusion3" | CF_in (_, c1), CF_aux _, White _ | CF_in (_, c1), White _, CF_aux _ | CF_in (_, c1), White _, White _ | CF_aux _, CF_in (_, c1), White _ | White _, CF_in (_, c1), CF_aux _ | White _, CF_in (_, c1), White _ | CF_aux _, White _, CF_in (_, c1) | White _, CF_aux _, CF_in (_, c1) | White _, White _, CF_in (_, c1) -> if nc1 > 0 then [CF_in (f, c1), v] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_aux _, CF_aux _ | CF_aux _, CF_out (_, c1'), CF_aux _ | CF_aux _, CF_aux _, CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), mult_vertex ( 2) v] else colored_vertex "colorize_fusion3" | CF_out (_, c1'), CF_aux _, White _ | CF_out (_, c1'), White _, CF_aux _ | CF_out (_, c1'), White _, White _ | CF_aux _, CF_out (_, c1'), White _ | White _, CF_out (_, c1'), CF_aux _ | White _, CF_out (_, c1'), White _ | CF_aux _, White _, CF_out (_, c1') | White _, CF_aux _, CF_out (_, c1') | White _, White _, CF_out (_, c1') -> if nc1 < 0 then [CF_out (f, c1'), v] else colored_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_out _ | CF_in _, CF_out _, CF_in _ | CF_out _, CF_in _, CF_in _ -> if nc1 > 0 then color_flow_ambiguous "colorize_fusion3" else colored_vertex "colorize_fusion3" | CF_in _, CF_out _, CF_out _ | CF_out _, CF_in _, CF_out _ | CF_out _, CF_out _, CF_in _ -> if nc1 < 0 then color_flow_ambiguous "colorize_fusion3" else colored_vertex "colorize_fusion3" | CF_in _, CF_in _, CF_in _ | CF_out _, CF_out _, CF_out _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" end | C.AdjSUN nc -> begin match f1, f2, f3 with | CF_in (_, c1), CF_out (_, c1'), White _ | CF_out (_, c1'), CF_in (_, c1), White _ | CF_in (_, c1), White _, CF_out (_, c1') | CF_out (_, c1'), White _, CF_in (_, c1) | White _, CF_in (_, c1), CF_out (_, c1') | White _, CF_out (_, c1'), CF_in (_, c1) -> if c1 <> c1' then [CF_io (f, c1, c1'), v] else [CF_aux f, v] | CF_in (_, c1), CF_out (_, c1'), CF_aux _ | CF_out (_, c1'), CF_in (_, c1), CF_aux _ | CF_in (_, c1), CF_aux _, CF_out (_, c1') | CF_out (_, c1'), CF_aux _, CF_in (_, c1) | CF_aux _, CF_in (_, c1), CF_out (_, c1') | CF_aux _, CF_out (_, c1'), CF_in (_, c1) -> if c1 <> c1' then [CF_io (f, c1, c1'), mult_vertex ( 2) v] else [CF_aux f, mult_vertex ( 2) v] | CF_in (_, c1), CF_out (_, c1'), CF_io (_, c2, c2') | CF_out (_, c1'), CF_in (_, c1), CF_io (_, c2, c2') | CF_in (_, c1), CF_io (_, c2, c2'), CF_out (_, c1') | CF_out (_, c1'), CF_io (_, c2, c2'), CF_in (_, c1) | CF_io (_, c2, c2'), CF_in (_, c1), CF_out (_, c1') | CF_io (_, c2, c2'), CF_out (_, c1'), CF_in (_, c1) -> if c1 = c2' && c2 = c1' then [CF_aux f, mult_vertex ( 2) v] else if c1 = c2' then [CF_io (f, c2, c1'), v] else if c2 = c1' then [CF_io (f, c1, c2'), v] else [] (* \begin{equation} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3,d4,e4} \fmf{gluon}{v,e1} \fmf{gluon}{v,e2} \fmf{gluon}{v,e3} \fmf{gluon}{v,e4} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmflabel{4}{e4} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e1} \fmf{warrow_right}{v,e2} \fmf{warrow_right}{v,e3} \fmf{warrow_right}{v,e4} \end{fmfgraph*}}} \,= \begin{split} \mbox{} - & \ii g^2 f_{a_1a_2b}f_{a_3a_4b} (g_{\mu_1\mu_3} g_{\mu_4\mu_2} - g_{\mu_1\mu_4} g_{\mu_2\mu_3}) \\ \mbox{} - & \ii g^2 f_{a_1a_3b}f_{a_4a_2b} (g_{\mu_1\mu_4} g_{\mu_2\mu_3} - g_{\mu_1\mu_2} g_{\mu_3\mu_4}) \\ \mbox{} - & \ii g^2 f_{a_1a_4b}f_{a_2a_3b} (g_{\mu_1\mu_2} g_{\mu_3\mu_4} - g_{\mu_1\mu_3} g_{\mu_4\mu_2}) \end{split} \end{equation} *) (* Using \begin{equation} \label{eq:P4} \mathcal{P}_4 = \left\{\{1,2,3,4\},\{1,3,4,2\},\{1,4,2,3\}, \{1,2,4,3\},\{1,4,3,2\},\{1,3,2,4\}\right\} \end{equation} as the set of permutations of~$\{1,2,3,4\}$ with the cyclic permutations factored out, we have: \begin{equation} \label{eq:4GV} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3,d4,e4} \fmf{phantom}{v,e1} \fmf{phantom}{v,e2} \fmf{phantom}{v,e3} \fmf{phantom}{v,e4} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmflabel{4}{e4} \fmffreeze \fmfi{phantom_arrow}{(reverse vpath (__e1, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e2, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e3, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e4, __v) sideways -thick)} \fmfi{phantom_arrow}{(reverse vpath (__e4, __v) sideways -thick)} \fmfi{phantom_arrow}{( vpath (__e1, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e1, __v) sideways -thick) join ( vpath (__e2, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e2, __v) sideways -thick) join ( vpath (__e3, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e3, __v) sideways -thick) join ( vpath (__e4, __v) sideways -thick)} \fmfi{plain}{% (reverse vpath (__e4, __v) sideways -thick) join ( vpath (__e1, __v) sideways -thick)} \end{fmfgraph*}}} \,= \begin{aligned} \ii g^2 \sum_{\{\alpha_k\}_{k=1,2,3,4}\in\mathcal{P}_4} \delta^{i_{\alpha_1}j_{\alpha_2}}\delta^{i_{\alpha_2}j_{\alpha_3}} \delta^{i_{\alpha_3}j_{\alpha_4}}\delta^{i_{\alpha_4}j_{\alpha_1}}\qquad\qquad\\ \left( 2g_{\mu_{\alpha_1}\mu_{\alpha_3}} g_{\mu_{\alpha_4}\mu_{\alpha_2}} - g_{\mu_{\alpha_1}\mu_{\alpha_4}} g_{\mu_{\alpha_2}\mu_{\alpha_3}} - g_{\mu_{\alpha_1}\mu_{\alpha_2}} g_{\mu_{\alpha_3}\mu_{\alpha_4}}\right) \end{aligned} \end{equation} *) (* The different color connections correspond to permutations of the particles entering the fusion and have to be matched by a corresponding permutation of the Lorentz structure: *) (* \begin{dubious} We have to generalize this for cases of four particles in the adjoint that are not all gluons: \begin{itemize} \item scalar-scalar-scalar-scalar \item scalar-scalar-vector-vector \end{itemize} and even ones including fermions (gluinos) if higher dimensional operators are involved. \end{dubious} *) | CF_io (_, c1, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') -> if c1' = c2 && c2' = c3 then [CF_io (f, c1, c3'), permute_vertex4 P123 v] else if c1' = c3 && c3' = c2 then [CF_io (f, c1, c2'), permute_vertex4 P132 v] else if c2' = c3 && c3' = c1 then [CF_io (f, c2, c1'), permute_vertex4 P231 v] else if c2' = c1 && c1' = c3 then [CF_io (f, c2, c3'), permute_vertex4 P213 v] else if c3' = c1 && c1' = c2 then [CF_io (f, c3, c2'), permute_vertex4 P312 v] else if c3' = c2 && c2' = c1 then [CF_io (f, c3, c1'), permute_vertex4 P321 v] else [] | CF_io _, CF_io _, CF_aux _ | CF_io _, CF_aux _, CF_io _ | CF_aux _, CF_io _, CF_io _ | CF_io _, CF_aux _, CF_aux _ | CF_aux _, CF_aux _, CF_io _ | CF_aux _, CF_io _, CF_aux _ | CF_aux _, CF_aux _, CF_aux _ -> [] | CF_io (_, c1, c1'), CF_io (_, c2, c2'), White _ | CF_io (_, c1, c1'), White _, CF_io (_, c2, c2') | White _, CF_io (_, c1, c1'), CF_io (_, c2, c2') -> if c1' = c2 then [CF_io (f, c1, c2'), mult_vertex (-1) v] else if c2' = c1 then [CF_io (f, c2, c1'), mult_vertex ( 1) v] else [] | CF_io (_, c1, c1'), CF_aux _, White _ | CF_aux _, CF_io (_, c1, c1'), White _ | CF_io (_, c1, c1'), White _, CF_aux _ | CF_aux _, White _, CF_io (_, c1, c1') | White _, CF_io (_, c1, c1'), CF_aux _ | White _, CF_aux _, CF_io (_, c1, c1') -> [] | CF_aux _, CF_aux _, White _ | CF_aux _, White _, CF_aux _ | White _, CF_aux _, CF_aux _ -> [] | White _, White _, CF_io (_, c1, c1') | White _, CF_io (_, c1, c1'), White _ | CF_io (_, c1, c1'), White _, White _ -> [CF_io (f, c1, c1'), v] | White _, White _, CF_aux _ | White _, CF_aux _, White _ | CF_aux _, White _, White _ -> [] | White _, White _, White _ | (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _) | (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _) | (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _), (White _ | CF_io _ | CF_aux _) | CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _) | CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _ | (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _ | CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _) | CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _ | (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _ | (CF_in _ | CF_out _), (CF_in _ | CF_out _), (CF_in _ | CF_out _) -> colored_vertex "colorize_fusion3" end (* \thocwmodulesubsection{Quintic and Higher Vertices} *) let is_white = function | White _ -> true | _ -> false let colorize_fusionn flist (f, v) = let incomplete_match () = incomplete ("colorize_fusionn { " ^ String.concat ", " (List.map (pullback M.flavor_to_string) flist) ^ " } -> " ^ M.flavor_to_string f) in match M.color f with | C.Singlet -> if List.for_all is_white flist then [White f, v] else incomplete_match () | C.SUN _ -> if List.for_all is_white flist then colored_vertex "colorize_fusionn" else incomplete_match () | C.AdjSUN _ -> if List.for_all is_white flist then colored_vertex "colorize_fusionn" else incomplete_match () end (* \thocwmodulesection{Colorizing a Monochrome Model} *) module It (M : Model.T) = struct open Coupling module C = Color module Colored_Flavor = Flavor(M) type flavor = Colored_Flavor.t type flavor_sans_color = M.flavor let flavor_sans_color = Colored_Flavor.flavor_sans_color type gauge = M.gauge type constant = M.constant let options = M.options open Colored_Flavor let color = pullback M.color let nc = M.nc let pdg = pullback M.pdg let lorentz = pullback M.lorentz module Ch = M.Ch let charges = pullback M.charges (* For the propagator we cannot use pullback because we have to add the case of the color singlet propagator by hand. *) let cf_aux_propagator = function | Prop_Scalar -> Prop_Col_Scalar (* Spin 0 octets. *) | Prop_Majorana -> Prop_Col_Majorana (* Spin 1/2 octets. *) | Prop_Feynman -> Prop_Col_Feynman (* Spin 1 states, massless. *) | Prop_Unitarity -> Prop_Col_Unitarity (* Spin 1 states, massive. *) | Aux_Scalar -> Aux_Col_Scalar (* constant colored scalar propagator *) | Aux_Vector -> Aux_Col_Vector (* constant colored vector propagator *) | Aux_Tensor_1 -> Aux_Col_Tensor_1 (* constant colored tensor propagator *) | Prop_Col_Scalar | Prop_Col_Feynman | Prop_Col_Majorana | Prop_Col_Unitarity | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> failwith ("Colorize.It().colorize_propagator: already colored particle!") | _ -> failwith ("Colorize.It().colorize_propagator: impossible!") let propagator = function | CF_aux f -> cf_aux_propagator (M.propagator f) | White f -> M.propagator f | CF_in (f, _) -> M.propagator f | CF_out (f, _) -> M.propagator f | CF_io (f, _, _) -> M.propagator f let width = pullback M.width let goldstone = function | White f -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (White f', g) end | CF_in (f, c) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_in (f', c), g) end | CF_out (f, c) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_out (f', c), g) end | CF_io (f, c1, c2) -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_io (f', c1, c2), g) end | CF_aux f -> begin match M.goldstone f with | None -> None | Some (f', g) -> Some (CF_aux f', g) end let conjugate = function | White f -> White (M.conjugate f) | CF_in (f, c) -> CF_out (M.conjugate f, c) | CF_out (f, c) -> CF_in (M.conjugate f, c) | CF_io (f, c1, c2) -> CF_io (M.conjugate f, c2, c1) | CF_aux f -> CF_aux (M.conjugate f) let conjugate_sans_color = M.conjugate let fermion = pullback M.fermion let max_degree = M.max_degree let flavors () = invalid "flavors" let external_flavors () = invalid "external_flavors" let parameters = M.parameters let split_color_string s = try let i1 = String.index s '/' in let i2 = String.index_from s (succ i1) '/' in let sf = String.sub s 0 i1 and sc1 = String.sub s (succ i1) (i2 - i1 - 1) and sc2 = String.sub s (succ i2) (String.length s - i2 - 1) in (sf, sc1, sc2) with | Not_found -> (s, "", "") let flavor_of_string s = try let sf, sc1, sc2 = split_color_string s in let f = M.flavor_of_string sf in match M.color f with | C.Singlet -> White f | C.SUN nc -> if nc > 0 then CF_in (f, color_flow_of_string sc1) else CF_out (f, color_flow_of_string sc2) | C.AdjSUN _ -> begin match sc1, sc2 with | "", "" -> CF_aux f | _, _ -> CF_io (f, color_flow_of_string sc1, color_flow_of_string sc2) end with - | Failure "int_of_string" -> - invalid_arg "Colorize().flavor_of_string: expecting integer" + | Failure s -> + if s = "int_of_string" then + invalid_arg "Colorize().flavor_of_string: expecting integer" + else + failwith ("Colorize().flavor_of_string: unexpected Failure(" ^ s ^ ")") let flavor_to_string = function | White f -> M.flavor_to_string f | CF_in (f, c) -> M.flavor_to_string f ^ "/" ^ string_of_int c ^ "/" | CF_out (f, c) -> M.flavor_to_string f ^ "//" ^ string_of_int c | CF_io (f, c1, c2) -> M.flavor_to_string f ^ "/" ^ string_of_int c1 ^ "/" ^ string_of_int c2 | CF_aux f -> M.flavor_to_string f ^ "//" let flavor_to_TeX = function | White f -> M.flavor_to_TeX f | CF_in (f, c) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ string_of_int c ^ "}" | CF_out (f, c) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut\\overline{" ^ string_of_int c ^ "}}" | CF_io (f, c1, c2) -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ string_of_int c1 ^ "\\overline{" ^ string_of_int c2 ^ "}}" | CF_aux f -> "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut 0}" let flavor_symbol = function | White f -> M.flavor_symbol f | CF_in (f, c) -> M.flavor_symbol f ^ "_" ^ string_of_int c ^ "_" | CF_out (f, c) -> M.flavor_symbol f ^ "__" ^ string_of_int c | CF_io (f, c1, c2) -> M.flavor_symbol f ^ "_" ^ string_of_int c1 ^ "_" ^ string_of_int c2 | CF_aux f -> M.flavor_symbol f ^ "__" let gauge_symbol = M.gauge_symbol (* Masses and widths must not depend on the colors anyway! *) let mass_symbol = pullback M.mass_symbol let width_symbol = pullback M.width_symbol let constant_symbol = M.constant_symbol (* \thocwmodulesubsection{Vertices} *) (* [vertices] are \emph{only} used by functor applications and for indexing a cache of precomputed fusion rules, which is not used for colorized models. *) let vertices () = invalid "vertices" module Legacy = Legacy_Implementation (M) let colorize_fusion2 f1 f2 (f, v) = match v with | V3 _ -> Legacy.colorize_fusion2 f1 f2 (f, v) | _ -> [] let colorize_fusion3 f1 f2 f3 (f, v) = match v with | V4 _ -> Legacy.colorize_fusion3 f1 f2 f3 (f, v) | _ -> [] (* In order to match the \emph{correct} positions of the fields in the vertices, we have to undo the permutation effected by the fusion according to [Coupling.fusen]. *) module PosMap = Partial.Make (struct type t = int let compare = compare end) (* Note that due to the [inverse], the list [l'] can be interpreted here as a map reshuffling the indices. E.\,g., [inverse (Permutation.Default.list [2;0;1])] applied to [[1;2;3]] gives [[3;1;2]]. *) let partial_map_redoing_permutation l l' = let module P = Permutation.Default in let p = P.inverse (P.of_list (List.map pred l')) in PosMap.of_lists l (P.list p l) (* Note that, the list [l'] can not be interpreted as a map reshuffling the indices, but gives the new order of the argument. E.\,g., [Permutation.Default.list [2;0;1]] applied to [[1;2;3]] gives [[2;3;1]]. *) let partial_map_undoing_permutation l l' = let module P = Permutation.Default in let p = P.of_list (List.map pred l') in PosMap.of_lists l (P.list p l) module CA = Color.Arrow module CV = Color.Vertex module CP = Color.Propagator let color_sans_flavor = function | White _ -> CP.W | CF_in (_, cfi) -> CP.I cfi | CF_out (_, cfo) -> CP.O cfo | CF_io (_, cfi, cfo) -> CP.IO (cfi, cfo) | CF_aux _ -> CP.G let color_with_flavor f = function | CP.W -> White f | CP.I cfi -> CF_in (f, cfi) | CP.O cfo -> CF_out (f, cfo) | CP.IO (cfi, cfo) -> CF_io (f, cfi, cfo) | CP.G -> CF_aux f let colorize vertex_list flavors f v = List.map (fun (coef, cf) -> (color_with_flavor f cf, cmult_vertex coef v)) (CV.fuse (nc ()) vertex_list (List.map color_sans_flavor flavors)) let partial_map_undoing_fusen fusen = partial_map_undoing_permutation (ThoList.range 1 (List.length fusen)) fusen let undo_permutation_of_fusen fusen = PosMap.apply_with_fallback (fun _ -> invalid_arg "permutation_of_fusen") (partial_map_undoing_fusen fusen) let colorize_fusionn_ufo flist f c v spins flines color fuse xtra = let v = Vn (UFO (c, v, spins, flines, Color.Vertex.unit), fuse, xtra) in let p = undo_permutation_of_fusen fuse in colorize (CV.map p color) flist f v let colorize_fusionn flist (f, v) = match v with | Vn (UFO (c, v, spins, flines, color), fuse, xtra) -> colorize_fusionn_ufo flist f c v spins flines color fuse xtra | _ -> [] let fuse_list flist = ThoList.flatmap (colorize_fusionn flist) (M.fuse (List.map flavor_sans_color flist)) let fuse2 f1 f2 = List.rev_append (fuse_list [f1; f2]) (ThoList.flatmap (colorize_fusion2 f1 f2) (M.fuse2 (flavor_sans_color f1) (flavor_sans_color f2))) let fuse3 f1 f2 f3 = List.rev_append (fuse_list [f1; f2; f3]) (ThoList.flatmap (colorize_fusion3 f1 f2 f3) (M.fuse3 (flavor_sans_color f1) (flavor_sans_color f2) (flavor_sans_color f3))) let fuse = function | [] | [_] -> invalid_arg "Colorize.It().fuse" | [f1; f2] -> fuse2 f1 f2 | [f1; f2; f3] -> fuse3 f1 f2 f3 | flist -> fuse_list flist let max_degree = M.max_degree (* \thocwmodulesubsection{Adding Color to External Particles} *) let count_color_strings f_list = let rec count_color_strings' n_in n_out n_glue = function | f :: rest -> begin match M.color f with | C.Singlet -> count_color_strings' n_in n_out n_glue rest | C.SUN nc -> if nc > 0 then count_color_strings' (succ n_in) n_out n_glue rest else if nc < 0 then count_color_strings' n_in (succ n_out) n_glue rest else su0 "count_color_strings" | C.AdjSUN _ -> count_color_strings' (succ n_in) (succ n_out) (succ n_glue) rest end | [] -> (n_in, n_out, n_glue) in count_color_strings' 0 0 0 f_list let external_color_flows f_list = let n_in, n_out, n_glue = count_color_strings f_list in if n_in <> n_out then [] else let color_strings = ThoList.range 1 n_in in List.rev_map (fun permutation -> (color_strings, permutation)) (Combinatorics.permute color_strings) (* If there are only adjoints \emph{and} there are no couplings of adjoints to singlets, we can ignore the $\mathrm{U}(1)$-ghosts. *) let pure_adjoints f_list = List.for_all (fun f -> match M.color f with C.AdjSUN _ -> true | _ -> false) f_list let two_adjoints_couple_to_singlets () = let vertices3, vertices4, verticesn = M.vertices () in List.exists (fun ((f1, f2, f3), _, _) -> match M.color f1, M.color f2, M.color f3 with | C.AdjSUN _, C.AdjSUN _, C.Singlet | C.AdjSUN _, C.Singlet, C.AdjSUN _ | C.Singlet, C.AdjSUN _, C.AdjSUN _ -> true | _ -> false) vertices3 || List.exists (fun ((f1, f2, f3, f4), _, _) -> match M.color f1, M.color f2, M.color f3, M.color f4 with | C.AdjSUN _, C.AdjSUN _, C.Singlet, C.Singlet | C.AdjSUN _, C.Singlet, C.AdjSUN _, C.Singlet | C.Singlet, C.AdjSUN _, C.AdjSUN _, C.Singlet | C.AdjSUN _, C.Singlet, C.Singlet, C.AdjSUN _ | C.Singlet, C.AdjSUN _, C.Singlet, C.AdjSUN _ | C.Singlet, C.Singlet, C.AdjSUN _, C.AdjSUN _ -> true | _ -> false) vertices4 || List.exists (fun (flist, _, g) -> true) verticesn let external_ghosts f_list = if pure_adjoints f_list then two_adjoints_couple_to_singlets () else true (* We use [List.hd] and [List.tl] instead of pattern matching, because we consume [ecf_in] and [ecf_out] at a different pace. *) let tail_opt = function | [] -> [] | _ :: tail -> tail let head_req = function | [] -> invalid_arg "Colorize.It().colorize_crossed_amplitude1: insufficient flows" | x :: _ -> x let rec colorize_crossed_amplitude1 ghosts acc f_list (ecf_in, ecf_out) = match f_list, ecf_in, ecf_out with | [], [], [] -> [List.rev acc] | [], _, _ -> invalid_arg "Colorize.It().colorize_crossed_amplitude1: leftover flows" | f :: rest, _, _ -> begin match M.color f with | C.Singlet -> colorize_crossed_amplitude1 ghosts (White f :: acc) rest (ecf_in, ecf_out) | C.SUN nc -> if nc > 0 then colorize_crossed_amplitude1 ghosts (CF_in (f, head_req ecf_in) :: acc) rest (tail_opt ecf_in, ecf_out) else if nc < 0 then colorize_crossed_amplitude1 ghosts (CF_out (f, head_req ecf_out) :: acc) rest (ecf_in, tail_opt ecf_out) else su0 "colorize_flavor" | C.AdjSUN _ -> let ecf_in' = head_req ecf_in and ecf_out' = head_req ecf_out in if ecf_in' = ecf_out' then begin if ghosts then colorize_crossed_amplitude1 ghosts (CF_aux f :: acc) rest (tail_opt ecf_in, tail_opt ecf_out) else [] end else colorize_crossed_amplitude1 ghosts (CF_io (f, ecf_in', ecf_out') :: acc) rest (tail_opt ecf_in, tail_opt ecf_out) end let colorize_crossed_amplitude1 ghosts f_list (ecf_in, ecf_out) = colorize_crossed_amplitude1 ghosts [] f_list (ecf_in, ecf_out) let colorize_crossed_amplitude f_list = ThoList.rev_flatmap (colorize_crossed_amplitude1 (external_ghosts f_list) f_list) (external_color_flows f_list) let cross_uncolored p_in p_out = (List.map M.conjugate p_in) @ p_out let uncross_colored n_in p_lists_colorized = let p_in_out_colorized = List.map (ThoList.splitn n_in) p_lists_colorized in List.map (fun (p_in_colored, p_out_colored) -> (List.map conjugate p_in_colored, p_out_colored)) p_in_out_colorized let amplitude p_in p_out = uncross_colored (List.length p_in) (colorize_crossed_amplitude (cross_uncolored p_in p_out)) (* The $-$-sign in the second component is redundant, but a Whizard convention. *) let indices = function | White _ -> Color.Flow.of_list [0; 0] | CF_in (_, c) -> Color.Flow.of_list [c; 0] | CF_out (_, c) -> Color.Flow.of_list [0; -c] | CF_io (_, c1, c2) -> Color.Flow.of_list [c1; -c2] | CF_aux f -> Color.Flow.ghost () let flow p_in p_out = (List.map indices p_in, List.map indices p_out) end (* \thocwmodulesection{Colorizing a Monochrome Gauge Model} *) module Gauge (M : Model.Gauge) = struct module CM = It(M) type flavor = CM.flavor type flavor_sans_color = CM.flavor_sans_color type gauge = CM.gauge type constant = CM.constant module Ch = CM.Ch let charges = CM.charges let flavor_sans_color = CM.flavor_sans_color let color = CM.color let pdg = CM.pdg let lorentz = CM.lorentz let propagator = CM.propagator let width = CM.width let conjugate = CM.conjugate let conjugate_sans_color = CM.conjugate_sans_color let fermion = CM.fermion let max_degree = CM.max_degree let vertices = CM.vertices let fuse2 = CM.fuse2 let fuse3 = CM.fuse3 let fuse = CM.fuse let flavors = CM.flavors let nc = CM.nc let external_flavors = CM.external_flavors let goldstone = CM.goldstone let parameters = CM.parameters let flavor_of_string = CM.flavor_of_string let flavor_to_string = CM.flavor_to_string let flavor_to_TeX = CM.flavor_to_TeX let flavor_symbol = CM.flavor_symbol let gauge_symbol = CM.gauge_symbol let mass_symbol = CM.mass_symbol let width_symbol = CM.width_symbol let constant_symbol = CM.constant_symbol let options = CM.options let incomplete s = failwith ("Colorize.Gauge()." ^ s ^ " not done yet!") type matter_field = M.matter_field type gauge_boson = M.gauge_boson type other = M.other type field = | Matter of matter_field | Gauge of gauge_boson | Other of other let field f = incomplete "field" let matter_field f = incomplete "matter_field" let gauge_boson f = incomplete "gauge_boson" let other f = incomplete "other" let amplitude = CM.amplitude let flow = CM.flow end Index: trunk/omega/src/combinatorics.ml =================================================================== --- trunk/omega/src/combinatorics.ml (revision 8305) +++ trunk/omega/src/combinatorics.ml (revision 8306) @@ -1,565 +1,569 @@ (* combinatorics.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +(* Avoid refering to [Pervasives.compare], because [Pervasives] will + become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *) +let pcompare = compare + type 'a seq = 'a list (* \thocwmodulesection{Simple Combinatorial Functions} *) let rec factorial' fn n = if n < 1 then fn else factorial' (n * fn) (pred n) let factorial n = let result = factorial' 1 n in if result < 0 then invalid_arg "Combinatorics.factorial overflow" else result (* \begin{multline} \binom{n}{k} = \frac{n!}{k!(n-k)!} = \frac{n(n-1)\cdots(n-k+1)}{k(k-1)\cdots1} \\ = \frac{n(n-1)\cdots(k+1)}{(n-k)(n-k-1)\cdots1} = \begin{cases} B_{n-k+1}(n,k) & \text{for $k \le \lfloor n/2 \rfloor$} \\ B_{k+1}(n,n-k) & \text{for $k > \lfloor n/2 \rfloor$} \end{cases} \end{multline} where \begin{equation} B_{n_{\min}}(n,k) = \begin{cases} n B_{n_{\min}}(n-1,k) & \text{for $n \ge n_{\min}$} \\ \frac{1}{k} B_{n_{\min}}(n,k-1) & \text{for $k > 1$} \\ 1 & \text{otherwise} \end{cases} \end{equation} *) let rec binomial' n_min n k acc = if n >= n_min then binomial' n_min (pred n) k (n * acc) else if k > 1 then binomial' n_min n (pred k) (acc / k) else acc let binomial n k = if k > n / 2 then binomial' (k + 1) n (n - k) 1 else binomial' (n - k + 1) n k 1 (* Overflows later, but takes much more time: \begin{equation} \binom{n}{k} = \binom{n-1}{k} + \binom{n-1}{k-1} \end{equation} *) let rec slow_binomial n k = if n < 0 || k < 0 then invalid_arg "Combinatorics.binomial" else if k = 0 || k = n then 1 else slow_binomial (pred n) k + slow_binomial (pred n) (pred k) let multinomial n_list = List.fold_left (fun acc n -> acc / (factorial n)) (factorial (List.fold_left (+) 0 n_list)) n_list let symmetry l = List.fold_left (fun s (n, _) -> s * factorial n) 1 (ThoList.classify l) (* \thocwmodulesection{Partitions} *) (* The inner steps of the recursion (i.\,e.~$n=1$) are expanded as follows \begin{multline} \ocwlowerid{split'}(1,\lbrack p_k;p_{k-1};\ldots;p_1\rbrack, \lbrack x_l;x_{l-1};\ldots;x_1\rbrack, \lbrack x_{l+1};x_{l+2};\ldots;x_m\rbrack ) = \\ \lbrack (\lbrack p_1;\ldots;p_k;x_{l+1}\rbrack, \lbrack x_1;\ldots;x_l;x_{l+2};\ldots;x_m\rbrack); \qquad\qquad\qquad\\ (\lbrack p_1;\ldots;p_k;x_{l+2}\rbrack, \lbrack x_1;\ldots;x_l;x_{l+1};x_{l+3}\ldots;x_m\rbrack); \ldots; \\ (\lbrack p_1;\ldots;p_k;x_m\rbrack, \lbrack x_1;\ldots;x_l;x_{l+1};\ldots;x_{m-1}\rbrack) \rbrack \end{multline} while the outer steps (i.\,e.~$n>1$) perform the same with one element moved from the last argument to the first argument. At the $n$th level we have \begin{multline} \ocwlowerid{split'}(n,\lbrack p_k;p_{k-1};\ldots;p_1\rbrack, \lbrack x_l;x_{l-1};\ldots;x_1\rbrack, \lbrack x_{l+1};x_{l+2};\ldots;x_m\rbrack ) = \\ \lbrack (\lbrack p_1;\ldots;p_k;x_{l+1};x_{l+2};\ldots;x_{l+n}\rbrack, \lbrack x_1;\ldots;x_l;x_{l+n+1};\ldots;x_m\rbrack); \ldots; \qquad\\ (\lbrack p_1;\ldots;p_k;x_{m-n+1};x_{m-n+2};\ldots;x_{m}\rbrack, \lbrack x_1;\ldots;x_l;x_{l+1};\ldots;x_{m-n}\rbrack) \rbrack \end{multline} where the order of the~$\lbrack x_1;x_2;\ldots;x_m\rbrack$ is maintained in the partitions. Variations on this multiple recursion idiom are used many times below. *) let rec split' n rev_part rev_head = function | [] -> [] | x :: tail -> let rev_part' = x :: rev_part and parts = split' n rev_part (x :: rev_head) tail in if n < 1 then failwith "Combinatorics.split': can't happen" else if n = 1 then (List.rev rev_part', List.rev_append rev_head tail) :: parts else split' (pred n) rev_part' rev_head tail @ parts (* Kick off the recursion for $0 (b, a)) (split' (abs_l - n) [] [] l) (* Check the arguments and call the workhorse: *) let ordered_split n l = let abs_l = List.length l in if n < 0 || n > abs_l then invalid_arg "Combinatorics.ordered_split" else ordered_split_unsafe n abs_l l (* Handle equipartitions specially: *) let split n l = let abs_l = List.length l in if n < 0 || n > abs_l then invalid_arg "Combinatorics.split" else begin if 2 * n = abs_l then match l with | [] -> failwith "Combinatorics.split: can't happen" | x :: tail -> List.map (fun (p1, p2) -> (x :: p1, p2)) (split' (pred n) [] [] tail) else ordered_split_unsafe n abs_l l end (* If we chop off parts repeatedly, we can either keep permutations or suppress them. Generically, [attach_to_fst] has type \begin{quote} [('a * 'b) list -> 'a list -> ('a list * 'b) list -> ('a list * 'b) list] \end{quote} and semantics \begin{multline} \ocwlowerid{attach\_to\_fst} (\lbrack (a_1,b_1),(a_2,b_2),\ldots,(a_m,b_m)\rbrack, \lbrack a'_1,a'_2,\ldots\rbrack) = \\ \lbrack (\lbrack a_1,a'_1,\ldots\rbrack, b_1), (\lbrack a_2,a'_1,\ldots\rbrack, b_2),\ldots, (\lbrack a_m,a'_1,\ldots\rbrack, b_m)\rbrack \end{multline} (where some of the result can be filtered out), assumed to be prepended to the final argument. *) let rec multi_split' attach_to_fst n size splits = if n <= 0 then splits else multi_split' attach_to_fst (pred n) size (List.fold_left (fun acc (parts, tail) -> attach_to_fst (ordered_split size tail) parts acc) [] splits) let attach_to_fst_unsorted splits parts acc = List.fold_left (fun acc' (p, rest) -> (p :: parts, rest) :: acc') acc splits (* Similarly, if the secod argument is a list of lists: *) let prepend_to_fst_unsorted splits parts acc = List.fold_left (fun acc' (p, rest) -> (p @ parts, rest) :: acc') acc splits let attach_to_fst_sorted splits parts acc = match parts with | [] -> List.fold_left (fun acc' (p, rest) -> ([p], rest) :: acc') acc splits | p :: _ as parts -> List.fold_left (fun acc' (p', rest) -> if p' > p then (p' :: parts, rest) :: acc' else acc') acc splits let multi_split n size l = multi_split' attach_to_fst_sorted n size [([], l)] let ordered_multi_split n size l = multi_split' attach_to_fst_unsorted n size [([], l)] let rec partitions' splits = function | [] -> List.map (fun (h, r) -> (List.rev h, r)) splits | (1, size) :: more -> partitions' (List.fold_left (fun acc (parts, rest) -> attach_to_fst_unsorted (split size rest) parts acc) [] splits) more | (n, size) :: more -> partitions' (List.fold_left (fun acc (parts, rest) -> prepend_to_fst_unsorted (multi_split n size rest) parts acc) [] splits) more let partitions multiplicities l = if List.fold_left (+) 0 multiplicities <> List.length l then invalid_arg "Combinatorics.partitions" else List.map fst (partitions' [([], l)] (ThoList.classify (List.sort compare multiplicities))) let rec ordered_partitions' splits = function | [] -> List.map (fun (h, r) -> (List.rev h, r)) splits | size :: more -> ordered_partitions' (List.fold_left (fun acc (parts, rest) -> attach_to_fst_unsorted (ordered_split size rest) parts acc) [] splits) more let ordered_partitions multiplicities l = if List.fold_left (+) 0 multiplicities <> List.length l then invalid_arg "Combinatorics.ordered_partitions" else List.map fst (ordered_partitions' [([], l)] multiplicities) let hdtl = function | [] -> invalid_arg "Combinatorics.hdtl" | h :: t -> (h, t) let factorized_partitions multiplicities l = ThoList.factorize (List.map hdtl (partitions multiplicities l)) (* In order to construct keystones (cf.~chapter~\ref{sec:topology}), we must eliminate reflectionsc consistently. For this to work, the lengths of the parts \emph{must not} be reordered arbitrarily. Ordering with monotonously fallings lengths would be incorrect however, because then some remainders could fake a reflection symmetry and partitions would be dropped erroneously. Therefore we put the longest first and order the remaining with rising lengths: *) let longest_first l = match ThoList.classify (List.sort (fun n1 n2 -> compare n2 n1) l) with | [] -> [] | longest :: rest -> longest :: List.rev rest let keystones multiplicities l = if List.fold_left (+) 0 multiplicities <> List.length l then invalid_arg "Combinatorics.keystones" else List.map fst (partitions' [([], l)] (longest_first multiplicities)) let factorized_keystones multiplicities l = ThoList.factorize (List.map hdtl (keystones multiplicities l)) (* \thocwmodulesection{Choices} *) (* The implementation is very similar to [split'], but here we don't have to keep track of the complements of the chosen sets. *) let rec choose' n rev_choice = function | [] -> [] | x :: tail -> let rev_choice' = x :: rev_choice and choices = choose' n rev_choice tail in if n < 1 then failwith "Combinatorics.choose': can't happen" else if n = 1 then List.rev rev_choice' :: choices else choose' (pred n) rev_choice' tail @ choices (* [choose n] is equivalent to $(\ocwlowerid{List.map}\,\ocwlowerid{fst})\circ (\ocwlowerid{split\_ordered}\,\ocwlowerid{n})$, but more efficient. *) let choose n l = let abs_l = List.length l in if n < 0 then invalid_arg "Combinatorics.choose" else if n > abs_l then [] else if n = 0 then [[]] else if n = abs_l then [l] else choose' n [] l let multi_choose n size l = List.map fst (multi_split n size l) let ordered_multi_choose n size l = List.map fst (ordered_multi_split n size l) (* \thocwmodulesection{Permutations} *) let rec insert x = function | [] -> [[x]] | h :: t as l -> (x :: l) :: List.rev_map (fun l' -> h :: l') (insert x t) let permute l = List.fold_left (fun acc x -> ThoList.rev_flatmap (insert x) acc) [[]] l (* \thocwmodulesubsection{Graded Permutations} *) let rec insert_signed x = function | (eps, []) -> [(eps, [x])] | (eps, h :: t) -> (eps, x :: h :: t) :: (List.map (fun (eps', l') -> (-eps', h :: l')) (insert_signed x (eps, t))) let rec permute_signed' = function | (eps, []) -> [(eps, [])] | (eps, h :: t) -> ThoList.flatmap (insert_signed h) (permute_signed' (eps, t)) let permute_signed l = permute_signed' (1, l) (* The following are wasting at most a factor of two and there's probably no point in improving on this \ldots *) let filter_sign s l = List.map snd (List.filter (fun (eps, _) -> eps = s) l) let permute_even l = filter_sign 1 (permute_signed l) let permute_odd l = filter_sign (-1) (permute_signed l) (* \begin{dubious} We have a slight inconsistency here: [permute [] = [[]]], while [permute_cyclic [] = []]. I don't know if it is worth fixing. \end{dubious} *) let permute_cyclic l = let rec permute_cyclic' acc l1 = function | [] -> List.rev acc | x :: rest as l2 -> permute_cyclic' ((l2 @ List.rev l1) :: acc) (x :: l1) rest in permute_cyclic' [] [] l (* \thocwmodulesubsection{Tensor Products of Permutations} *) let permute_tensor ll = Product.list (fun l -> l) (List.map permute ll) let join_signs l = let el, pl = List.split l in (List.fold_left (fun acc x -> x * acc) 1 el, pl) let permute_tensor_signed ll = Product.list join_signs (List.map permute_signed ll) let permute_tensor_even l = filter_sign 1 (permute_tensor_signed l) let permute_tensor_odd l = filter_sign (-1) (permute_tensor_signed l) (* \thocwmodulesubsection{Sorting} *) let insert_inorder_signed order x (eps, l) = let rec insert eps' accu = function | [] -> (eps * eps', List.rev_append accu [x]) | h :: t -> if order x h = 0 then invalid_arg "Combinatorics.insert_inorder_signed: identical elements" else if order x h < 0 then (eps * eps', List.rev_append accu (x :: h :: t)) else insert (-eps') (h::accu) t in insert 1 [] l -let sort_signed ?(cmp=Pervasives.compare) l = +let sort_signed ?(cmp=pcompare) l = List.fold_right (insert_inorder_signed cmp) l (1, []) -let sign ?(cmp=Pervasives.compare) l = +let sign ?(cmp=pcompare) l = let eps, _ = sort_signed ~cmp l in eps -let sign2 ?(cmp=Pervasives.compare) l = +let sign2 ?(cmp=pcompare) 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 cmp a.(i) a.(j) > 0 then eps := - !eps done done; !eps module Test = struct open OUnit let to_string = ThoList.to_string (ThoList.to_string string_of_int) let assert_equal_perms = assert_equal ~printer:to_string let count_permutations n = let factorial_n = factorial n and range = ThoList.range 1 n in let sorted = List.sort compare (permute range) in (* Verify the count \ldots *) assert_equal factorial_n (List.length sorted); (* \ldots{} check that they're all different \ldots *) assert_equal factorial_n (List.length (ThoList.uniq sorted)); (* \ldots{} make sure that they a all permutations. *) assert_equal_perms [range] (ThoList.uniq (List.map (List.sort compare) sorted)) let suite_permute = "permute" >::: [ "permute []" >:: (fun () -> assert_equal_perms [[]] (permute [])); "permute [1]" >:: (fun () -> assert_equal_perms [[1]] (permute [1])); "permute [1;2;3]" >:: (fun () -> assert_equal_perms [ [2; 3; 1]; [2; 1; 3]; [3; 2; 1]; [1; 3; 2]; [1; 2; 3]; [3; 1; 2] ] (permute [1; 2; 3])); "permute [1;2;3;4]" >:: (fun () -> assert_equal_perms [ [3; 4; 1; 2]; [3; 1; 2; 4]; [3; 1; 4; 2]; [4; 3; 1; 2]; [1; 4; 2; 3]; [1; 2; 3; 4]; [1; 2; 4; 3]; [4; 1; 2; 3]; [1; 4; 3; 2]; [1; 3; 2; 4]; [1; 3; 4; 2]; [4; 1; 3; 2]; [3; 4; 2; 1]; [3; 2; 1; 4]; [3; 2; 4; 1]; [4; 3; 2; 1]; [2; 4; 1; 3]; [2; 1; 3; 4]; [2; 1; 4; 3]; [4; 2; 1; 3]; [2; 4; 3; 1]; [2; 3; 1; 4]; [2; 3; 4; 1]; [4; 2; 3; 1] ] (permute [1; 2; 3; 4])); "count permute 5" >:: (fun () -> count_permutations 5); "count permute 6" >:: (fun () -> count_permutations 6); "count permute 7" >:: (fun () -> count_permutations 7); "count permute 8" >:: (fun () -> count_permutations 8); "cyclic []" >:: (fun () -> assert_equal_perms [] (permute_cyclic [])); "cyclic [1]" >:: (fun () -> assert_equal_perms [[1]] (permute_cyclic [1])); "cyclic [1;2;3]" >:: (fun () -> assert_equal_perms [[1;2;3]; [2;3;1]; [3;1;2]] (permute_cyclic [1;2;3])); "cyclic [1;2;3;4]" >:: (fun () -> assert_equal_perms [[1;2;3;4]; [2;3;4;1]; [3;4;1;2]; [4;1;2;3]] (permute_cyclic [1;2;3;4]))] let sort_signed_not_unique = "not unique" >:: (fun () -> assert_raises (Invalid_argument "Combinatorics.insert_inorder_signed: identical elements") (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 [1;2;4;3;6;5])) let sort_signed_odd = "odd" >:: (fun () -> assert_equal (-1, [1;2;3;4;5;6]) (sort_signed [2;3;1;5;4;6])) let sort_signed_all = "all" >:: (fun () -> let l = ThoList.range 1 8 in assert_bool "all signed permutations" (List.for_all (fun (eps, p) -> let eps', p' = sort_signed p in eps' = eps && p' = l) (permute_signed l))) let sign_sign2 = "sign/sign2" >:: (fun () -> let l = ThoList.range 1 8 in assert_bool "all permutations" (List.for_all (fun p -> sign p = sign2 p) (permute l))) let suite_sort_signed = "sort_signed" >::: [sort_signed_not_unique; sort_signed_even; sort_signed_odd; sort_signed_all; sign_sign2] let suite = "Combinatorics" >::: [suite_permute; suite_sort_signed] end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/UFOx_syntax.mli =================================================================== --- trunk/omega/src/UFOx_syntax.mli (revision 8305) +++ trunk/omega/src/UFOx_syntax.mli (revision 8306) @@ -1,48 +1,53 @@ (* vertex_syntax.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Abstract Syntax} *) exception Syntax_Error of string * Lexing.position * Lexing.position type expr = | Integer of int | Float of float | Variable of string | Sum of expr * expr | Difference of expr * expr | Product of expr * expr | Quotient of expr * expr | Power of expr * expr | Application of string * expr list val integer : int -> expr val float : float -> expr val variable : string -> expr val add : expr -> expr -> expr val subtract : expr -> expr -> expr val multiply : expr -> expr -> expr val divide : expr -> expr -> expr val power : expr -> expr -> expr val apply : string -> expr list -> expr + +(* Return the sets of variable and function names referenced + in the expression. *) +val variables : expr -> Sets.String_Caseless.t +val functions : expr -> Sets.String_Caseless.t Index: trunk/omega/src/permutation.ml =================================================================== --- trunk/omega/src/permutation.ml (revision 8305) +++ trunk/omega/src/permutation.ml (revision 8306) @@ -1,389 +1,407 @@ (* permutation.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from cf. main AUTHORS file WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig type t val of_list : int list -> t val of_array : int array -> t val of_lists : 'a list -> 'a list -> t val inverse : t -> t val compose : t -> t -> t val compose_inv : t -> t -> t val list : t -> 'a list -> 'a list val array : t -> 'a array -> 'a array val all : int -> t list val even : int -> t list val odd : int -> t list val cyclic : int -> t list val signed : int -> (int * t) list val to_string : t -> string end let same_elements l1 l2 = List.sort compare l1 = List.sort compare l2 module PM = Pmap.Tree let offset_map l = let _, offsets = List.fold_left (fun (i, map) a -> (succ i, PM.add compare a i map)) (0, PM.empty) l in offsets (* TODO: this algorithm fails if the lists contain duplicate elements. *) let of_lists_list l l' = if same_elements l l' then let offsets' = offset_map l' in let _, p_rev = List.fold_left (fun (i, acc) a -> (succ i, PM.find compare a offsets' :: acc)) (0, []) l in List.rev p_rev else invalid_arg "Permutation.of_lists: incompatible lists" module Using_Lists : T = struct type t = int list let of_list p = if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then invalid_arg "Permutation.of_list" else p let of_array p = try of_list (Array.to_list p) with - | Invalid_argument "Permutation.of_list" -> - invalid_arg "Permutation.of_array" + | Invalid_argument s -> + if s = "Permutation.of_list" then + invalid_arg "Permutation.of_array" + else + failwith ("Permutation.of_array: unexpected Invalid_argument(" ^ + s ^ ")") let of_lists = of_lists_list let inverse p = snd (ThoList.ariadne_sort p) let list p l = List.map snd (List.sort (fun (i, _) (j, _) -> compare i j) (try List.rev_map2 (fun i x -> (i, x)) p l with - | Invalid_argument "List.rev_map2" -> - invalid_arg "Permutation.list: length mismatch")) + | Invalid_argument s -> + if s = "List.rev_map2" then + invalid_arg "Permutation.list: length mismatch" + else + failwith ("Permutation.list: unexpected Invalid_argument(" ^ + s ^ ")"))) let array p a = try Array.of_list (list p (Array.to_list a)) with - | Invalid_argument "Permutation.list: length mismatch" -> - invalid_arg "Permutation.array: length mismatch" + | Invalid_argument s -> + if s = "Permutation.list: length mismatch" then + invalid_arg "Permutation.array: length mismatch" + else + failwith ("Permutation.array: unexpected Invalid_argument(" ^ s ^ ")") let compose_inv p q = list q p (* Probably not optimal (or really inefficient), but correct by associativity. *) let compose p q = list (inverse q) p let all n = List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n))) let even n = List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n))) let odd n = List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n))) let cyclic n = List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n))) let signed n = List.map (fun (eps, l) -> (eps, of_list l)) (Combinatorics.permute_signed (ThoList.range 0 (pred n))) let to_string p = String.concat "" (List.map string_of_int p) end module Using_Arrays : T = struct type t = int array let of_list p = if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then invalid_arg "Permutation.of_list" else Array.of_list p let of_array p = try of_list (Array.to_list p) with - | Invalid_argument "Permutation.of_list" -> - invalid_arg "Permutation.of_array" + | Invalid_argument s -> + if s = "Permutation.of_list" then + invalid_arg "Permutation.of_array" + else + failwith ("Permutation.of_array: unexpected Invalid_argument(" ^ + s ^ ")") let of_lists l l' = Array.of_list (of_lists_list l l') let inverse p = let len_p = Array.length p in let p' = Array.make len_p p.(0) in for i = 0 to pred len_p do p'.(p.(i)) <- i done; p' let array p a = let len_a = Array.length a and len_p = Array.length p in if len_a <> len_p then invalid_arg "Permutation.array: length mismatch"; let a' = Array.make len_a a.(0) in for i = 0 to pred len_a do a'.(p.(i)) <- a.(i) done; a' let list p l = try Array.to_list (array p (Array.of_list l)) with - | Invalid_argument "Permutation.array: length mismatch" -> - invalid_arg "Permutation.list: length mismatch" + | Invalid_argument s -> + if s = "Permutation.array: length mismatch" then + invalid_arg "Permutation.list: length mismatch" + else + failwith ("Permutation.list: unexpected Invalid_argument(" ^ s ^ ")") let compose_inv p q = array q p let compose p q = array (inverse q) p let all n = List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n))) let even n = List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n))) let odd n = List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n))) let cyclic n = List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n))) let signed n = List.map (fun (eps, l) -> (eps, of_list l)) (Combinatorics.permute_signed (ThoList.range 0 (pred n))) let to_string p = String.concat "" (List.map string_of_int (Array.to_list p)) end module Default = Using_Arrays (* This is the Fisher-Yates shuffle, cf. D. Knuth, {\em Seminumerical algorithms. The Art of Computer Programming. 2}. Reading, MA: Addison–Wesley. pp. 139-140. *) (*i To shuffle an array a of n elements (indices 0..n-1): for i from n − 1 downto 1 do j ← random integer with 0 ≤ j ≤ i exchange a[j] and a[i] To initialize an array a of n elements to a randomly shuffled copy of source, both 0-based: a[0] ← source[0] for i from 1 to n − 1 do j ← random integer with 0 ≤ j ≤ i a[i] ← a[j] a[j] ← source[i] i*) let shuffle l = let a = Array.of_list l in for n = Array.length a - 1 downto 1 do let k = Random.int (succ n) in if k <> n then let tmp = Array.get a n in Array.set a n (Array.get a k); Array.set a k tmp done; Array.to_list a let time f x = let start = Sys.time () in let f_x = f x in let stop = Sys.time () in (f_x, stop -. start) let print_time msg f x = let f_x, seconds = time f x in Printf.printf "%s took %10.2f ms\n" msg (seconds *. 1000.); f_x let random_int_list imax n = let imax_plus = succ imax in Array.to_list (Array.init n (fun _ -> Random.int imax_plus)) module Test (P : T) : sig val suite : OUnit.test val time : unit -> unit end = struct open OUnit open P let of_list_overlap = "overlap" >:: (fun () -> assert_raises (Invalid_argument "Permutation.of_list") (fun () -> of_list [0;1;2;2])) let of_list_gap = "gap" >:: (fun () -> assert_raises (Invalid_argument "Permutation.of_list") (fun () -> of_list [0;1;2;4;5])) let of_list_ok = "ok" >:: (fun () -> let l = ThoList.range 0 10 in assert_equal (of_list l) (of_list l)) let suite_of_list = "of_list" >::: [of_list_overlap; of_list_gap; of_list_ok] let suite_of_lists = "of_lists" >::: [ "ok" >:: (fun () -> for i = 1 to 10 do let l = random_int_list 1000000 100 in let l' = shuffle l in assert_equal ~printer:(ThoList.to_string string_of_int) l' (list (of_lists l l') l) done) ] let apply_invalid_lengths = "invalid/lengths" >:: (fun () -> assert_raises (Invalid_argument "Permutation.list: length mismatch") (fun () -> list (of_list [0;1;2;3;4]) [0;1;2;3])) let apply_ok = "ok" >:: (fun () -> assert_equal [2;0;1;3;5;4] (list (of_list [1;2;0;3;5;4]) [0;1;2;3;4;5])) let suite_apply = "apply" >::: [apply_invalid_lengths; apply_ok] let inverse_ok = "ok" >:: (fun () -> let l = shuffle (ThoList.range 0 1000) in let p = of_list (shuffle l) in assert_equal l (list (inverse p) (list p l))) let suite_inverse = "inverse" >::: [inverse_ok] let compose_ok = "ok" >:: (fun () -> let id = ThoList.range 0 1000 in let p = of_list (shuffle id) and q = of_list (shuffle id) and l = id in assert_equal (list p (list q l)) (list (compose p q) l)) let compose_inverse_ok = "inverse/ok" >:: (fun () -> let id = ThoList.range 0 1000 in let p = of_list (shuffle id) and q = of_list (shuffle id) in assert_equal (compose (inverse p) (inverse q)) (inverse (compose q p))) let suite_compose = "compose" >::: [compose_ok; compose_inverse_ok] let suite = "Permutations" >::: [suite_of_list; suite_of_lists; suite_apply; suite_inverse; suite_compose] let repeat repetitions size = let id = ThoList.range 0 size in let p = of_list (shuffle id) and l = shuffle (List.map string_of_int id) in print_time (Printf.sprintf "reps=%d, len=%d" repetitions size) (fun () -> for i = 1 to repetitions do ignore (P.list p l) done) () let time () = repeat 100000 10; repeat 10000 100; repeat 1000 1000; repeat 100 10000; repeat 10 100000; () end Index: trunk/omega/src/UFO_tools.mli =================================================================== --- trunk/omega/src/UFO_tools.mli (revision 0) +++ trunk/omega/src/UFO_tools.mli (revision 8306) @@ -0,0 +1,28 @@ +(* UFO_tools.mli -- + + Copyright (C) 1999-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + with contributions from + Christian Speckner + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +(* Translate Mathematica symbols to Fortran symbols. *) +val mathematica_symbol : string -> string -> string + +exception Lexical_Error of string * Lexing.position * Lexing.position Index: trunk/omega/src/sets.mli =================================================================== --- trunk/omega/src/sets.mli (revision 8305) +++ trunk/omega/src/sets.mli (revision 8306) @@ -1,24 +1,25 @@ (* sets.mli -- Copyright (C) 2019- by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module String : Set.S with type elt = string +module String_Caseless : Set.S with type elt = string module Int : Set.S with type elt = int Index: trunk/omega/src/test_ufo.sh =================================================================== --- trunk/omega/src/test_ufo.sh (revision 8305) +++ trunk/omega/src/test_ufo.sh (revision 8306) @@ -1,9 +1,9 @@ #! /bin/sh jobs=12 UFO=$HOME/physics/SM/ root=$HOME/physics/whizard -build=$root/_build +build=$root/_build/default make -j $jobs -C $build/omega/src || exit 1 make -j $jobs -C $build/omega/tests ufo_unit || exit 1 $build/omega/tests/ufo_unit "$@" Index: trunk/omega/src/Makefile.am =================================================================== --- trunk/omega/src/Makefile.am (revision 8305) +++ trunk/omega/src/Makefile.am (revision 8306) @@ -1,212 +1,212 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## # Build the O'Mega Fortran library using libtool # (?use pkglib_ instead of lib_ to make the -rpath and *.lai business work ...) lib_LTLIBRARIES = libomega_core.la moduleexecincludedir = $(pkgincludedir)/../omega nodist_moduleexecinclude_DATA = $(OMEGALIB_MOD) libomega_core_la_SOURCES = $(OMEGALIB_F90) EXTRA_DIST = \ $(OMEGA_CAML) \ omegalib.nw $(OMEGALIB_F90) OMEGA_CMXA = omega_core.cmxa omega_targets.cmxa omega_models.cmxa OMEGA_CMA = $(OMEGA_CMXA:.cmxa=.cma) if OCAML_AVAILABLE all-local: $(OMEGA_CMXA) $(OMEGA_APPLICATIONS_CMX) bytecode: $(OMEGA_CMA) $(OMEGA_APPLICATIONS_CMO) else all-local: bytecode: endif # Compiled interfaces and libraries for out-of-tree compilation of models if OCAML_AVAILABLE camllibdir = $(pkglibdir)/../omega/caml nodist_camllib_DATA = \ omega.cmi fusion.cmi targets.cmi coupling.cmi modeltools.cmi color.cmi \ options.cmi model.cmi \ omega_core.cmxa omega_core.a omega_targets.cmxa omega_targets.a \ charges.cmi endif ######################################################################## include $(top_srcdir)/omega/src/Makefile.ocaml include $(top_srcdir)/omega/src/Makefile.sources if OCAML_AVAILABLE omega_core.a: omega_core.cmxa omega_core.cmxa: $(OMEGA_CORE_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_core.cma: $(OMEGA_CORE_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ omega_targets.a: omega_targets.cmxa omega_targets.cmxa: $(OMEGA_TARGETS_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_targets.cma: $(OMEGA_TARGETS_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ omega_models.cmxa: $(OMEGA_MODELS_CMX) @if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi $(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^ omega_models.cma: $(OMEGA_MODELS_CMO) @if $(AM_V_P); then :; else echo " OCAMLC " $@; fi $(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^ cascade_lexer.mli: cascade_lexer.ml cascade_parser.cmi $(OCAMLC) -i $< | $(GREP) 'val token' >$@ vertex_lexer.mli: vertex_lexer.ml vertex_parser.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ -UFO_lexer.mli: UFO_lexer.ml UFO_parser.cmi +UFO_lexer.mli: UFO_lexer.ml UFO_parser.cmi UFO_tools.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ -UFOx_lexer.mli: UFOx_lexer.ml UFOx_parser.cmi +UFOx_lexer.mli: UFOx_lexer.ml UFOx_parser.cmi UFO_tools.cmi $(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@ endif MYPRECIOUS = $(OMEGA_DERIVED_CAML) SUFFIXES += .lo .$(FC_MODULE_EXT) # Fortran90 module files are generated at the same time as object files .lo.$(FC_MODULE_EXT): @: # touch $@ ######################################################################## DISTCLEANFILES = kinds.f90 if NOWEB_AVAILABLE omegalib.stamp: $(srcdir)/omegalib.nw @rm -f omegalib.tmp @touch omegalib.tmp for src in $(OMEGALIB_DERIVED_F90); do \ $(NOTANGLE) -R[[$$src]] $< | $(CPIF) $$src; \ done @mv -f omegalib.tmp omegalib.stamp $(OMEGALIB_DERIVED_F90): omegalib.stamp ## Recover from the removal of $@ @if test -f $@; then :; else \ rm -f omegalib.stamp; \ $(MAKE) $(AM_MAKEFLAGS) omegalib.stamp; \ fi DISTCLEANFILES += $(OMEGALIB_DERIVED_F90) endif NOWEB_AVAILABLE MYPRECIOUS += $(OMEGALIB_DERIVED_F90) ######################################################################## # The following line just says # include Makefile.depend_fortran # but in a portable fashion (depending on automake's AM_MAKE_INCLUDE ######################################################################## @am__include@ @am__quote@Makefile.depend_fortran@am__quote@ Makefile.depend_fortran: kinds.f90 $(libomega_core_la_SOURCES) @rm -f $@ for src in $^; do \ module="`basename $$src | sed 's/\.f[90][0358]//'`"; \ grep '^ *use ' $$src \ | grep -v '!NODEP!' \ | sed -e 's/^ *use */'$$module'.lo: /' \ -e 's/, *only:.*//' \ -e 's/, *&//' \ -e 's/, *.*=>.*//' \ -e 's/ *$$/.lo/' ; \ done > $@ DISTCLEANFILES += Makefile.depend_fortran if OCAML_AVAILABLE @am__include@ @am__quote@Makefile.depend_ocaml@am__quote@ PARSERS = cascade vertex UFO UFOx Makefile.depend_ocaml: $(OMEGA_CAML_PRIMARY) @if $(AM_V_P); then :; else echo " OCAMLDEP " $@; fi @rm -f $@ $(AM_V_at)$(OCAMLDEP) -I $(srcdir) $^ $(OMEGA_DERIVED_CAML) \ | sed 's,[^ ]*/,,g' > $@ $(AM_V_at)for parser in $(PARSERS); do \ echo $${parser}.cmi: $${parser}_lexer.cmi; \ echo $${parser}_lexer.cmi: $${parser}_parser.cmi; \ echo $${parser}_parser.cmi: $${parser}_syntax.cmi; \ echo $${parser}_parser.mli: $${parser}_parser.ml; \ echo $${parser}.cmo: $${parser}.cmi; \ echo $${parser}.cmx: $${parser}.cmi $${parser}_lexer.cmx; \ echo $${parser}_lexer.cmo: $${parser}_lexer.cmi; \ echo $${parser}_lexer.cmx: $${parser}_lexer.cmi $${parser}_parser.cmx; \ echo $${parser}_parser.cmo: $${parser}_parser.cmi $${parser}_syntax.cmi; \ echo $${parser}_parser.cmx: $${parser}_parser.cmi \ $${parser}_syntax.cmi $${parser}_syntax.cmx; \ done >>$@ DISTCLEANFILES += Makefile.depend_ocaml endif OCAML_AVAILABLE ######################################################################## # Don't trigger remakes by deleting intermediate files. .PRECIOUS = $(MYPRECIOUS) clean-local: rm -f *.cm[aiox] *.cmxa *.[ao] *.l[oa] *.$(FC_MODULE_EXT) \ $(OMEGA_DERIVED_CAML) omegalib.stamp if FC_SUBMODULES -rm -f *.smod endif distclean-local: -test "$(srcdir)" != "." && rm -f config.mli ######################################################################## ## The End. ######################################################################## Index: trunk/omega/src/UFO_lexer.mll =================================================================== --- trunk/omega/src/UFO_lexer.mll (revision 8305) +++ trunk/omega/src/UFO_lexer.mll (revision 8306) @@ -1,99 +1,110 @@ (* vertex_lexer.mll -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) { open Lexing open UFO_parser let string_of_char c = String.make 1 c let int_of_char c = int_of_string (string_of_char c) let init_position fname lexbuf = let curr_p = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { curr_p with pos_fname = fname; pos_lnum = 1; pos_bol = curr_p.pos_cnum }; lexbuf } let digit = ['0'-'9'] let upper = ['A'-'Z'] let lower = ['a'-'z'] let char = upper | lower let word = char | digit | '_' let white = [' ' '\t'] let esc = ['\'' '"' '\\'] let crlf = ['\r' '\n'] let not_crlf = [^'\r' '\n'] rule token = parse white { token lexbuf } (* skip blanks *) | '#' not_crlf* { token lexbuf } (* skip comments *) | crlf+ { new_line lexbuf; token lexbuf } | "from" not_crlf* { token lexbuf } (* skip imports *) | "import" not_crlf* { token lexbuf } (* skip imports (for now) *) | "try:" not_crlf* { token lexbuf } (* skip imports (for now) *) | "except" not_crlf* { token lexbuf } (* skip imports (for now) *) | "pass" { token lexbuf } (* skip imports (for now) *) | '(' { LPAREN } | ')' { RPAREN } | '{' { LBRACE } | '}' { RBRACE } | '[' { LBRACKET } | ']' { RBRACKET } | '=' { EQUAL } | '+' { PLUS } | '-' { MINUS } | '/' { DIV } | '.' { DOT } | ',' { COMMA } | ':' { COLON } | '-'? ( digit+ '.' digit* | digit* '.' digit+ ) ( ['E''e'] '-'? digit+ )? as x { FLOAT (float_of_string x) } | '-'? digit+ as i { INT (int_of_string i) } | char word* as s { ID s } + | '\\' '[' (word+ as stem) ']' (word* as suffix) + { ID (UFO_tools.mathematica_symbol stem suffix) } | '\'' { let sbuf = Buffer.create 20 in STRING (string1 sbuf lexbuf) } | '"' { let sbuf = Buffer.create 20 in STRING (string2 sbuf lexbuf) } - | _ as c { failwith ("invalid character at `" ^ - string_of_char c ^ "'") } + | _ as c { raise (UFO_tools.Lexical_Error + ("invalid character `" ^ string_of_char c ^ "'", + lexbuf.lex_start_p, lexbuf.lex_curr_p)) } | eof { END } and string1 sbuf = parse '\'' { Buffer.contents sbuf } | '\\' (esc as c) { Buffer.add_char sbuf c; string1 sbuf lexbuf } | eof { raise End_of_file } + | '\\' '[' (word+ as stem) ']' (word* as suffix) + { Buffer.add_string + sbuf (UFO_tools.mathematica_symbol stem suffix); + string1 sbuf lexbuf } | _ as c { Buffer.add_char sbuf c; string1 sbuf lexbuf } and string2 sbuf = parse '"' { Buffer.contents sbuf } | '\\' (esc as c) { Buffer.add_char sbuf c; string2 sbuf lexbuf } | eof { raise End_of_file } + | '\\' '[' (word+ as stem) ']' (word* as suffix) + { Buffer.add_string + sbuf (UFO_tools.mathematica_symbol stem suffix); + string2 sbuf lexbuf } | _ as c { Buffer.add_char sbuf c; string2 sbuf lexbuf } Index: trunk/omega/src/UFO_tools.ml =================================================================== --- trunk/omega/src/UFO_tools.ml (revision 0) +++ trunk/omega/src/UFO_tools.ml (revision 8306) @@ -0,0 +1,28 @@ +(* UFO_tools.ml -- + + Copyright (C) 1999-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + with contributions from + Christian Speckner + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +let mathematica_symbol stem stuffix = + Printf.sprintf "Mma_%s_%s" stem stuffix + +exception Lexical_Error of string * Lexing.position * Lexing.position Index: trunk/omega/src/UFOx_lexer.mll =================================================================== --- trunk/omega/src/UFOx_lexer.mll (revision 8305) +++ trunk/omega/src/UFOx_lexer.mll (revision 8306) @@ -1,73 +1,76 @@ (* vertex_lexer.mll -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) { open Lexing open UFOx_parser let string_of_char c = String.make 1 c let int_of_char c = int_of_string (string_of_char c) let init_position fname lexbuf = let curr_p = lexbuf.lex_curr_p in lexbuf.lex_curr_p <- { curr_p with pos_fname = fname; pos_lnum = 1; pos_bol = curr_p.pos_cnum }; lexbuf } let digit = ['0'-'9'] let upper = ['A'-'Z'] let lower = ['a'-'z'] let char = upper | lower let word = char | digit | '_' let white = [' ' '\t' '\n'] rule token = parse white { token lexbuf } (* skip blanks *) | '(' { LPAREN } | ')' { RPAREN } | ',' { COMMA } | '*' '*' { POWER } | '*' { TIMES } | '/' { DIV } | '+' { PLUS } | '-' { MINUS } | ( digit+ as i ) ( '.' '0'* )? { INT (int_of_string i) } | digit* '.' digit+ ( ['E''e'] '-'? digit+ )? as x { FLOAT (float_of_string x) } | char word* ('.' char word+ )? as s { ID s } - | _ as c { failwith ("invalid character at `" ^ - string_of_char c ^ "'") } + | '\\' '[' (word+ as stem) ']' (word* as suffix) + { ID (UFO_tools.mathematica_symbol stem suffix) } + | _ as c { raise (UFO_tools.Lexical_Error + ("invalid character `" ^ string_of_char c ^ "'", + lexbuf.lex_start_p, lexbuf.lex_curr_p)) } | eof { END } Index: trunk/omega/src/UFOx_syntax.ml =================================================================== --- trunk/omega/src/UFOx_syntax.ml (revision 8305) +++ trunk/omega/src/UFOx_syntax.ml (revision 8306) @@ -1,66 +1,84 @@ (* vertex_syntax.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Abstract Syntax} *) exception Syntax_Error of string * Lexing.position * Lexing.position type expr = | Integer of int | Float of float | Variable of string | Sum of expr * expr | Difference of expr * expr | Product of expr * expr | Quotient of expr * expr | Power of expr * expr | Application of string * expr list let integer i = Integer i let float x = Float x let variable s = Variable s let add e1 e2 = Sum (e1, e2) let subtract e1 e2 = Difference (e1, e2) let multiply e1 e2 = Product (e1, e2) let divide e1 e2 = Quotient (e1, e2) let power e p = Power (e, p) let apply f args = Application (f, args) - + +module CSet = Sets.String_Caseless + +let rec variables = function + | Integer _ | Float _ -> CSet.empty + | Variable name -> CSet.singleton name + | Sum (e1, e2) | Difference (e1, e2) + | Product (e1, e2) | Quotient (e1, e2) + | Power (e1, e2) -> CSet.union (variables e1) (variables e2) + | Application (_, elist) -> + List.fold_left CSet.union CSet.empty (List.map variables elist) + +let rec functions = function + | Integer _ | Float _ | Variable _ -> CSet.empty + | Sum (e1, e2) | Difference (e1, e2) + | Product (e1, e2) | Quotient (e1, e2) + | Power (e1, e2) -> CSet.union (functions e1) (functions e2) + | Application (f, elist) -> + List.fold_left CSet.union (CSet.singleton f) (List.map functions elist)