Page MenuHomeHEPForge
Files F11222426

color.ml
No OneTemporary
Actions

color.ml
View Options

(* $Id: color.ml 1811 2010-02-15 17:16:01Z ohl $
Copyright (C) 1999-2009 by
Wolfgang Kilian <kilian@hep.physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
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{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 NC =
sig
val nc : int
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
exception Open_flow
val power_of_nc : t -> t -> int option
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} *)
(* \begin{dubious}
The following code is \textbf{in development} and most
likely \textbf{not yet operational!}. Its only in the trunk,
because it doesn't disturb the rest. Please don't read it, because
the errors included can do damage to your brain \ldots
\end{dubious} *)
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 t2 =
| Square of (int * int) list
| Mismatch
exception Mismatched_Amplitudes
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
let square f1 f2 =
let rec square' next_free f1' f2' =
match f1', f2' with
| [], [] -> []
| _, [] | [], _ ->
raise Mismatched_Amplitudes
| Ghost :: rest1, Ghost :: rest2 ->
let c1 = next_free in
let c2 = succ c1 in
(c1, c2) :: (-c1, -c2) :: square' (next_free + 2) rest1 rest2
| Lines (0, 0) :: rest1, Lines (0, 0) :: rest2 ->
square' next_free rest1 rest2
| Lines (0, c1') :: rest1, Lines (0, c2') :: rest2 ->
(c1', c2') :: square' next_free rest1 rest2
| Lines (c1, 0) :: rest1, Lines (c2, 0) :: rest2 ->
(c1, c2) :: square' next_free rest1 rest2
| Lines (0, _) :: _, _ | _ , Lines (0, _) :: _
| Lines (_, 0) :: _, _ | _, Lines (_, 0) :: _ ->
raise Mismatched_Amplitudes
| Lines (c1, c1') :: rest1, Lines (c2, c2') :: rest2 ->
(c1, c2) :: (c1', c2') :: square' next_free rest1 rest2
| Lines (c1, c1') :: rest1, Ghost :: rest2 ->
let c2 = next_free in
(c1, c2) :: (c1', -c2) :: square' (succ next_free) rest1 rest2
| Ghost :: rest1, Lines (c2, c2') :: rest2 ->
let c1 = next_free in
(c1, c2) :: (-c1, c2') :: square' (succ next_free) rest1 rest2 in
try
Square (square'
(List.length (fst f1) + List.length (snd f1) + 1)
(cross_out f1) (cross_out f2))
with
| Mismatched_Amplitudes -> Mismatch
(* \begin{dubious}
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.
\end{dubious} *)
exception Open_flow
let rec find_fst c_final c1 seen = function
| [] -> raise Open_flow
| (c1', c2') as c12' :: rest ->
if c1 = c1' then
find_snd c_final (-c2') [] (List.rev_append seen rest)
else
find_fst c_final c1 (c12' :: seen) rest
and find_snd c_final c2 seen = function
| [] -> raise Open_flow
| (c1', c2') as c12' :: rest->
if c2' = c2 then begin
if c1' = c_final then
List.rev_append seen rest
else
find_fst c_final (-c1') [] (List.rev_append seen rest)
end else
find_snd c_final c2 (c12' :: seen) rest
let consume_cycle = function
| [] -> []
| (c1, c2) :: rest -> find_snd (-c1) (-c2) [] rest
let count_cycles colors =
let rec count_cycles' acc = function
| [] -> acc
| rest -> count_cycles' (succ acc) (consume_cycle rest) in
count_cycles' 0 colors
let power_of_nc f1 f2 =
match square f1 f2 with
| Square f12 -> Some (count_cycles (f12) - count_ghosts f1 - count_ghosts f2)
| Mismatch -> None
let of_pair (c1, c2) = of_list [c1; c2]
let of_pairs l1 l2 =
(List.map of_pair l1, List.map of_pair l2)
let f1 =
of_pairs [( 1, 0); ( 0, -1)] [( 2, 0); ( 0, -2)]
let f2 =
of_pairs [( 2, 0); ( 0, -1)] [( 2, 0); ( 0, -1)]
end
(*i
open Flow
#trace find_fst
#trace find_snd
#trace consume_cycle
let _ = count_cycles (square f1 f1)
let _ = count_cycles (square f2 f2)
let _ = count_cycles (square f1 f2)
let _ = count_cycles (square f2 f1)
i*)
(* 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
(*i
* Local Variables:
* mode:caml
* indent-tabs-mode:nil
* page-delimiter:"^(\\* .*\n"
* End:
i*)

File Metadata

Mime Type
text/x-tex
Expires
Wed, May 14, 11:52 AM (2 h, 12 s)
Storage Engine
blob
Storage Format
Raw Data
Storage Handle
5111547
Default Alt Text
color.ml (7 KB)

Event Timeline