Commit 792b1f0f authored by Thorsten Ohl's avatar Thorsten Ohl
Browse files

Merge branch 'UFO' (though not working yet)

parents 40943b48 a26d7105
......@@ -5,3 +5,4 @@ autom4te.cache/
configure
compile
foo*
*.in
......@@ -193,6 +193,35 @@ esac
OMEGA_CACHE_SUFFIX="vertices"
AC_SUBST([OMEGA_CACHE_SUFFIX])
AC_ARG_ENABLE([default-UFO-dir],
[ --enable-default-UFO-dir=directory
Read precomputed model tables from this directory,
which will be populated by an administrator at
install time [[default=$datadir/UFO, enabled]].],
[case "$enableval" in
no) OMEGA_DEFAULT_UFO_DIR="."
;;
*) OMEGA_DEFAULT_UFO_DIR="$enableval"
;;
esac],
[### use eval b/c $datadir defaults to unexpanded ${datarootdir}
case "$OMEGA_DEFAULT_UFO_DIR" in
"") OMEGA_DEFAULT_UFO_DIR="${prefix}/share/UFO"
;;
*) eval OMEGA_DEFAULT_UFO_DIR="$datadir/UFO"
;;
esac])
AC_SUBST([OMEGA_DEFAULT_UFO_DIR])
case "$OMEGA_DEFAULT_UFO_DIR" in
.|""|NONE*) OMEGA_DEFAULT_UFO_DIR="."
;;
*) AC_MSG_NOTICE([Creating default UFO directory $OMEGA_DEFAULT_UFO_DIR])
$MKDIR_P "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
chmod u+w "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
;;
esac
###---------------------------------------------------------------------
### Noweb
......@@ -284,7 +313,9 @@ fi
AC_ARG_ENABLE([model-files],
[AS_HELP_STRING([--enable-model-files],
[build the development code for model files (developers only) [[no]]])])
[build the development code for model files (developers only) [[yes]]])],
[],
[enable_model_files=yes])
AC_CACHE_CHECK([whether we want to build the development code for model files],
[wo_cv_model_files],
......
......@@ -90,11 +90,14 @@ omega_models.cma: $(OMEGA_MODELS_CMO)
cascade_lexer.mli: cascade_lexer.ml cascade_parser.cmi
$(OCAMLC) -i $< | $(GREP) 'val token' >$@
comphep_lexer.mli: comphep_lexer.ml comphep_parser.cmi
$(OCAMLC) -i $< | $(GREP) 'val token' >$@
vertex_lexer.mli: vertex_lexer.ml vertex_parser.cmi
$(OCAMLC) -i $< | $(GREP) 'val token' >$@
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
uFO_lexer.mli: uFO_lexer.ml uFO_parser.cmi
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
uFOx_lexer.mli: uFOx_lexer.ml uFOx_parser.cmi
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
endif
......@@ -161,7 +164,7 @@ if OCAML_AVAILABLE
@am__include@ @am__quote@Makefile.depend_ocaml@am__quote@
PARSERS = cascade comphep vertex
PARSERS = cascade vertex uFO uFOx
Makefile.depend_ocaml: $(OMEGA_CAML_PRIMARY)
@rm -f $@
......
......@@ -40,10 +40,12 @@ OCAML_BYTECODE_EXT = .bin
SUFFIXES = .mll .mly .ml .mli .cmi .cmo .cmx .bin .opt
.cmx$(OCAML_NATIVE_EXT):
$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ $(OMEGA_CMXA) $<
$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ \
unix.cmxa $(OMEGA_CMXA) $<
.cmo$(OCAML_BYTECODE_EXT):
$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ $(OMEGA_CMA) $<
$(OCAMLC) $(OCAMLDEBUGFLAGS) $(OCAMLFLAGS) -o $@ \
unix.cma $(OMEGA_CMA) $<
.ml.cmx:
$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o $@ -c $<
......
......@@ -58,20 +58,20 @@ 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
COMPHEP_MLL = comphep_lexer.mll
COMPHEP_MLY = comphep_parser.mly
COMPHEP_MLD = $(COMPHEP_MLL:.mll=.ml) $(COMPHEP_MLY:.mly=.ml)
COMPHEP_ML_PRIMARY = comphep_syntax.ml comphep.ml
COMPHEP_ML = comphep_syntax.ml $(COMPHEP_MLD) comphep.ml
VERTEX_MLL = @comment_model_file@ vertex_lexer.mll
VERTEX_MLY = @comment_model_file@ vertex_parser.mly
VERTEX_MLD = $(VERTEX_MLL:.mll=.ml) $(VERTEX_MLY:.mly=.ml)
VERTEX_ML_PRIMARY = @comment_model_file@ vertex_syntax.ml vertex.ml
VERTEX_ML = @comment_model_file@ vertex_syntax.ml $(VERTEX_MLD) vertex.ml
OMEGA_MLL = $(CASCADE_MLL) $(COMPHEP_MLL) $(VERTEX_MLL)
OMEGA_MLY = $(CASCADE_MLY) $(COMPHEP_MLY) $(VERTEX_MLY)
UFO_MLL = @comment_model_file@ uFOx_lexer.mll uFO_lexer.mll
UFO_MLY = @comment_model_file@ uFOx_parser.mly uFO_parser.mly
UFO_MLD = $(UFO_MLL:.mll=.ml) $(UFO_MLY:.mly=.ml)
UFO_ML_PRIMARY = @comment_model_file@ uFOx_syntax.ml uFOx.ml uFO_syntax.ml uFO.ml
UFO_ML = @comment_model_file@ uFOx_syntax.ml uFO_syntax.ml $(UFO_MLD) uFOx.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) \
......@@ -99,10 +99,10 @@ OMEGA_CORE_ML_PART1 = \
charges.ml color.ml modeltools.ml whizard.ml
OMEGA_CORE_ML_PART2 = \
$(VERTEX_ML) $(COMPHEP_ML) $(CASCADE_ML)
$(VERTEX_ML) $(UFO_ML) $(CASCADE_ML)
OMEGA_CORE_ML_PART2_PRIMARY = \
$(VERTEX_ML_PRIMARY) $(COMPHEP_ML_PRIMARY) $(CASCADE_ML_PRIMARY)
$(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY)
OMEGA_CORE_ML_PART3 = \
colorize.ml process.ml fusion.ml omega.ml
......@@ -196,7 +196,8 @@ OMEGA_APPLICATIONS_ML = \
omega_HSExt.ml \
omega_HSExt_VM.ml \
omega_Template.ml \
omega_SYM.ml
omega_SYM.ml \
omega_UFO.ml
OMEGA_CORE_CMO = $(OMEGA_CORE_ML:.ml=.cmo)
OMEGA_CORE_CMX = $(OMEGA_CORE_ML:.ml=.cmx)
......
......@@ -50,9 +50,18 @@ module type Rational =
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} *)
......@@ -77,15 +86,30 @@ module Small_Rational : Rational =
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)
......@@ -96,7 +120,13 @@ module Small_Rational : Rational =
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
(* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *)
......
......@@ -45,9 +45,18 @@ module type Rational =
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} *)
......
......@@ -379,6 +379,8 @@ let permute_tensor_even 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])
......@@ -393,14 +395,85 @@ let insert_inorder_signed order x (eps, l) =
in
insert 1 [] l
(* \thocwmodulesubsection{Sorting} *)
let sort_signed ?(cmp=Pervasives.compare) l =
List.fold_right (insert_inorder_signed cmp) l (1, [])
let sign ?(cmp=Pervasives.compare) l =
let eps, _ = sort_signed ~cmp l in
eps
let sign2 ?(cmp=Pervasives.compare) l =
let a = Array.of_list l in
let eps = ref 1 in
for j = 0 to Array.length a - 1 do
for i = 0 to j - 1 do
if cmp a.(i) a.(j) > 0 then
eps := - !eps
done
done;
!eps
module Test =
struct
open OUnit
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 8in
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 8in
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_sort_signed]
let sort_signed order l =
List.fold_left (fun acc x -> insert_inorder_signed order x acc) (1, []) l
end
(*i
* Local Variables:
* mode:caml
* indent-tabs-mode:nil
* page-delimiter:"^(\\* .*\n"
* End:
......
......@@ -152,13 +152,18 @@ val permute_tensor_signed : 'a seq list -> (int * 'a seq list) list
val permute_tensor_even : 'a seq list -> 'a seq list list
val permute_tensor_odd : 'a seq list -> 'a seq list list
val sign : ?cmp:('a -> 'a -> int) -> 'a seq -> int
(* \thocwmodulesubsection{Sorting} *)
val sort_signed : ('a -> 'a -> int) -> 'a list -> int * 'a list
val sort_signed : ?cmp:('a -> 'a -> int) -> 'a seq -> int * 'a seq
(* \thocwmodulesubsection{Unit Tests} *)
module Test : sig val suite : OUnit.test end
(*i
* Local Variables:
* mode:caml
* indent-tabs-mode:nil
* page-delimiter:"^(\\* .*\n"
* End:
......
(* $Id: comphep.ml 7444 2016-02-17 15:37:20Z jr_reuter $
Copyright (C) 1999-2016 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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 rcs_file = RCS.parse "Comphep" ["Plagiarizing CompHEP models ..."]
{ RCS.revision = "$Revision: 7444 $";
RCS.date = "$Date: 2016-02-17 16:37:20 +0100 (Wed, 17 Feb 2016) $";
RCS.author = "$Author: jr_reuter $";
RCS.source
= "$URL: svn+ssh://login.hepforge.org/hepforge/svn/whizard/trunk/omega/src/comphep.ml $" }
(* A friendlier [String.sub] that returns an empty string instead of
raising an exception. Instead of the length, the second argument
denotes the last position. *)
let substring buffer i1 i2 =
let imax = String.length buffer - 1 in
let i1 = max i1 0
and i2 = min i2 imax in
let len = i2 - i1 + 1 in
if len > 0 then
String.sub buffer i1 len
else
""
let first_non_white buffer =
let len = String.length buffer in
let rec skip_white i =
if i >= len then
i
else if buffer.[i] <> ' ' && buffer.[i] <> '\t' then
i
else
skip_white (succ i) in
skip_white 0
let last_non_white buffer =
let len = String.length buffer in
let rec skip_white i =
if i < 0 then
i
else if buffer.[i] <> ' ' && buffer.[i] <> '\t' then
i
else
skip_white (pred i) in
skip_white (pred len)
let gobble_white buffer =
substring buffer (first_non_white buffer) (last_non_white buffer)
let gobble_arrows buffer =
let imax = String.length buffer - 1 in
if imax >= 0 then
gobble_white
(substring buffer
(if buffer.[0] = '>' then 1 else 0)
(if buffer.[imax] = '<' then pred imax else imax))
else
""
let fold_lines ic f init =
let rec fold_lines' acc =
let continue =
try
let acc' = f (input_line ic) acc in
fun () -> fold_lines' acc'
with
| End_of_file -> fun () -> acc in
continue () in
fold_lines' init
let column_tabs line =
let len = String.length line in
let rec tabs' acc i =
if i >= len then
List.rev acc
else if line.[i] = '|' then
tabs' (i :: acc) (succ i)
else
tabs' acc (succ i)
in
tabs' [] 0
let columns tabs line =
let imax = String.length line - 1 in
let rec columns' acc i = function
| [] -> List.rev_map gobble_white (substring line i imax :: acc)
| tab :: rest ->
if tab < i then
invalid_arg "columns: clash"
else if (match rest with [] -> false | _ -> true)
&& line.[tab] <> '|' then
invalid_arg "columns: expecting '|'"
else
columns' (substring line i (pred tab) :: acc) (succ tab) rest
in
columns' [] 0 tabs
let input_table name =
let ic = open_in name in
let model = input_line ic in
let table = input_line ic in
let line = input_line ic in
let tabs = column_tabs line in
let titles = columns tabs line in
let rows = fold_lines ic (fun line acc ->
if String.length line > 0 && line.[0] = '=' then
acc
else
columns tabs line :: acc) [] in
close_in ic;
(gobble_white model, gobble_white table, List.map gobble_arrows titles, rows)
let substitute_char (cold, cnew) s =
for i = 0 to String.length s - 1 do
if s.[i] = cold then
s.[i] <- cnew
done;
s
let sanitize_symbol s =
List.fold_right substitute_char [('+', 'p'); ('-', 'm')] (String.copy s)
(* \begin{dubious}
Fodder for a future [Coupling] module \ldots
\end{dubious} *)
let rec fermion_of_lorentz = function
| Coupling.Spinor -> 1
| Coupling.ConjSpinor -> -1
| Coupling.Majorana -> 1
| Coupling.Maj_Ghost -> 1
| 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
let rec conjugate_lorentz = function
| Coupling.Spinor -> Coupling.ConjSpinor
| Coupling.ConjSpinor -> Coupling.Spinor
| Coupling.BRS f -> Coupling.BRS (conjugate_lorentz f)
| f -> f
(* \begin{dubious}
Currently, this operates on the sanitized symbol names.
\end{dubious} *)
let pdg_heuristic name =
match name with
| "e1" -> 11 | "E1" -> -11 | "n1" -> 12 | "N1" -> -12
| "e2" -> 13 | "E2" -> -13 | "n2" -> 14 | "N2" -> -14
| "e3" -> 15 | "E3" -> -15 | "n3" -> 16 | "N3" -> -16
| "u" -> 2 | "U" -> -2 | "d" -> 1 | "D" -> -1
| "c" -> 4 | "C" -> -4 | "s" -> 3 | "S" -> -3
| "t" -> 6 | "T" -> -6 | "b" -> 5 | "B" -> -5
| "G" -> 21 | "A" -> 22 | "Z" -> 23
| "Wp" -> 24 | "Wm" -> -24 | "H" -> 25
| _ -> invalid_arg ("pdg_heuristic failed: " ^ name)
module Model =
struct
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 lorentz = M.lorentz
let color = M.color
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 rcs = rcs_file
type symbol =
| Selfconjugate of string
| Conjugates of string * string
type particle =
{ p_name : string;
p_symbol : symbol;
p_spin : Coupling.lorentz;
p_mass : Comphep_syntax.raw;
p_width : Comphep_syntax.raw;
p_color : Color.t;
p_aux : string option }
let count_flavors particles =
List.fold_left (fun n p -> n +
match p.p_symbol with
| Selfconjugate _ -> 1
| Conjugates _ -> 2) 0 particles
type particle_flavor =
{ f_name : string;
f_conjugate : int;
f_symbol : string;
f_pdg : int;
f_spin : Coupling.lorentz;
f_propagator : gauge Coupling.propagator;
f_fermion : int;
f_mass : string;
f_width : string;
f_color : Color.t;
f_aux : string option }
let real_variable = function
| Comphep_syntax.Integer 0 -> "zero"
| Comphep_syntax.Symbol s -> s
| _ -> invalid_arg "real_variable"
let dummy_flavor =
{ f_name = "";
f_conjugate = -1;
f_symbol = "";
f_pdg = 0;
f_spin = Coupling.Scalar;
f_propagator = Coupling.Prop_Scalar;
f_fermion = 0;
f_mass = real_variable (Comphep_syntax.integer 0);
f_width = real_variable (Comphep_syntax.integer 0);