Skip to content

GitLab

Commit f3a4e3fd authored by Benoit Barbot's avatar Benoit Barbot
Browse files

add regexp

parent 4de7ba65
Hide whitespace changes
Inline Side-by-side
src/ZoneGraph.ml
View file @ f3a4e3fd
......@@ -226,9 +226,11 @@ let loczone_of_json fb _ t =
List.assoc_opt "redcoord" l
|>>> Util.to_list |>>| [] |> List.map int_list_json
in
let id = List.assoc "id" l |> Util.to_int in
{
name = List.assoc "name" l |> Util.to_string;
id = List.assoc "id" l |> Util.to_int;
id;
name =
List.assoc_opt "name" l |>>> Util.to_string |>>| "s_" ^ string_of_int id;
redcoord;
transition =
List.assoc "transition" l |> Util.to_list
......
src/automata.ml deleted 100644 → 0
View file @ 4de7ba65
let print_array p f v =
Array.iter (fun x -> p f x) v
let print_list p f v =
List.iter (fun x -> p f x) v
type l = char
module Det =
struct
type t = {
init: int;
trans: (l * int) list array;
final: bool array;
}
let init_volume a =
Array.map (function false -> 0.0 | true -> 1.0) a.final
let iterate_volume a oc =
let n = Array.length a.trans in
let nc = Array.make n 0.0 in
for i = 0 to n-1 do
nc.(i) <- List.fold_left (fun x (_,s) -> x +. oc.(s)) 0.0 a.trans.(i)
done;
nc
let compute_volume a n =
let t = ref [init_volume a] in
for i = 1 to n do
let v = List.hd !t in
Array.iter (fun x -> print_float x; print_string " ") v;
print_newline ();
t := (iterate_volume a v):: !t ;
done;
!t
exception Empty
let rec min_list = function
[] -> raise Empty
| [t] -> t
| (_,_,v1)::(x,y,v2)::q when v2 < v1 -> min_list ((x,y,v2)::q)
| t::_::q -> min_list (t::q)
let rec sample s a = function
[] -> []
| t::q ->
let (l,s2,_) =
a.trans.(s)
|> List.map (function (l,s2) -> l,s2,t.(s2))
|> List.map (function (l,s2,v) -> l,s2,(-.log (Random.float 1.0))/.v)
|> min_list in
l::(sample s2 a q)
end
module Notdet =
struct
module Tr = struct
type t = l*int
let compare t1 t2 = compare t1 t2
end
module TrSet = Set.Make(Tr)
type t = {
init: int list;
trans: TrSet.t array;
final: bool array;
}
let of_char c =
{ init = [0]; trans = [| TrSet.singleton (c,1); TrSet.empty |]; final= [|false;true|] }
let of_string s =
let n = String.length s in
{ init =[0]; trans = Array.init (n+1) (fun i ->
if i<n then TrSet.singleton (s.[i],i+1) else TrSet.empty);
final = Array.init (n+1) (fun i -> i=n) }
let print f t =
Format.fprintf f "{@[ init=[%a];@.trans=[|%a|];@.final=[|%a|]@]} "
(print_list (fun f x -> Format.fprintf f "%i, " x)) t.init
(print_array (fun f x ->
Format.fprintf f "{";
TrSet.iter (fun (l,i) -> Format.fprintf f "(%c,%i); " l i) x;
Format.fprintf f "}"
)) t.trans
(print_array (fun f x -> Format.fprintf f "%b, " x)) t.final
let print_dot f t =
Format.fprintf f "digraph notdet {@[@.%a%a%a@]}"
(fun f a -> Array.iteri (fun i x -> if x then Format.fprintf f "node[shape=doublecircle]; %i;@." i else Format.fprintf f "node[shape=circle]; %i;@." i) a) t.final
(fun f a -> List.iter (fun i -> Format.fprintf f "node[shape=point]; i%i;@.i%i -> %i;@." i i i)
a) t.init
(fun f a -> Array.iteri (fun i x ->
TrSet.iter (fun (l,j) -> Format.fprintf f "%i -> %i [label=\"%c\"];@." i j l) x) a) t.trans
let emonde a =
let n = Array.length a.trans in
let compt = Array.make n 0 in
List.iter (fun i -> compt.(i)<-compt.(i)+1) a.init;
Array.iter (fun tab ->
TrSet.iter (fun (_,j) -> compt.(j)<-compt.(j)+1) tab) a.trans;
let n2 = Array.fold_left (fun x y -> if y>0 then x+1 else x) 0 compt in
let trans = Array.make n2 TrSet.empty in
let final = Array.make n2 false in
let map = Array.make n 0 in
ignore @@ Array.fold_left (fun (i,j) c -> if c>0 then (
trans.(i)<-a.trans.(j);
final.(i)<-a.final.(j);
map.(j) <-i;
(i+1,j+1)
) else (i,j+1)) (0,0) compt;
let init = List.map (fun x -> map.(x)) a.init in
Array.iteri (fun i tr -> trans.(i) <- TrSet.map (fun (l,j) -> (l,map.(j))) tr) trans;
{init;trans;final}
let cat a1 a2 =
let n1 = Array.length a1.trans
and n2 = Array.length a2.trans in
let trans = Array.init (n1+n2) (fun i ->
if i<n1 then
let p = a1.trans.(i) in
if a1.final.(i) then
List.fold_left (fun it s ->
TrSet.fold (fun (l,s2) it2 -> TrSet.add (l,n1+s2) it2)
a2.trans.(s) it)
p a2.init
else p
else
TrSet.map (fun (l,s) -> (l,n1+s)) a2.trans.(i-n1)
) in
let initfinal = List.exists (fun i -> a2.final.(i)) a2.init in
let final = Array.init (n1+n2) (fun i ->
if i<n1 then a1.final.(i) && initfinal else a2.final.(i-n1)) in
emonde { init=a1.init; trans; final }
let merge a1 a2 =
let n1 = Array.length a1.trans
and n2 = Array.length a2.trans in
{
init = a1.init @ (List.map (fun x -> x+n1) a2.init);
trans = Array.init (n1+n2) (fun i ->
if i <n1 then a1.trans.(i)
else TrSet.map (fun (l,s) -> (l,s+n1)) a2.trans.(i-n1));
final = Array.init (n1+n2) (fun i ->
if i<n1 then a1.final.(i) else a2.final.(i-n1))
}
let star a =
let n = Array.length a.trans in
let trans = Array.init n (fun i ->
let p = a.trans.(i) in
if a.final.(i) then
List.fold_left (fun it s ->
TrSet.fold (fun (l,s2) it2 -> TrSet.add (l,s2) it2)
a.trans.(s) it)
p a.init
else p
) in
let final = Array.copy a.final in
List.iter (fun x -> final.(x) <- true) a.init;
{ a with trans; final }
let plus a =
cat a (star a)
let reverse a =
let n = Array.length a.trans in
let init = snd @@ Array.fold_left
(fun (i,l) x -> if x then (i+1),(i::l) else (i+1,l)) (0,[]) a.final in
let final = Array.make n false in
List.iter (fun i -> final.(i)<- true) a.init;
let trans = Array.make n TrSet.empty in
Array.iteri (fun i trset ->
TrSet.iter (fun (l,j) -> trans.(j) <- TrSet.add (l,i) trans.(j)) trset) a.trans;
{ init; trans;final }
module IntSet = Set.Make(struct type t=int let compare i j = i-j end)
let determinize a =
let init = IntSet.of_list a.init in
let set = Hashtbl.create 10 in
Hashtbl.add set init (ref None);
let cmpt = ref 0 in
let to_exp = ref [init] in
while !to_exp <> [] do
let ss = List.hd !to_exp in
to_exp := List.tl !to_exp;
let trfun = Hashtbl.create 2 in
IntSet.iter (fun s ->
TrSet.iter (fun (l,s2) ->
match Hashtbl.find_opt trfun l with
None -> Hashtbl.add trfun l (IntSet.singleton s2)
| Some (tset) -> Hashtbl.replace trfun l (IntSet.add s2 tset))
a.trans.(s))
ss;
(Hashtbl.find set ss) := (Some (trfun,!cmpt));
incr cmpt;
Hashtbl.iter (fun _ s ->
if not @@ Hashtbl.mem set s then (
Hashtbl.add set s (ref None);
to_exp := s :: !to_exp
)) trfun
done;
let trans = Array.make !cmpt TrSet.empty
and final = Array.make !cmpt false in
Hashtbl.iter (fun ss x ->
match !x with None -> assert (false)
| Some (trfun,s) ->
let tr = Hashtbl.fold (fun l ss2 trset ->
match !(Hashtbl.find set ss2) with
None -> assert (false)
| Some (_,c2) ->
TrSet.add (l,c2) trset) trfun TrSet.empty in
trans.(s)<-tr;
final.(s)<-IntSet.exists (fun x -> a.final.(x)) ss
) set;
{ init = [0]; trans; final}
let minimize a =
determinize @@ reverse @@ determinize @@ reverse a
let to_det a =
let a2 = determinize @@ reverse @@ determinize @@ reverse a in
{ Det.init= List.hd a2.init;
trans= Array.map (fun tr -> TrSet.fold (fun x l -> x::l) tr []) a2.trans;
final=a2.final
}
end
let testa = let open Det in {
init= 0;
trans= [|
['a',0 ; 'b',1];
['b',0 ; 'a',2];
['a',1 ; 'b',2]
|];
final= [| true; false; false |]
}
src/dune
View file @ f3a4e3fd
......@@ -24,6 +24,8 @@
(libraries wordgen_lib unix arguments)
(modes native))
(documentation
(mld_files :standard))
......
src/rational_fraction.ml
View file @ f3a4e3fd
......@@ -156,7 +156,6 @@ module Make (P : Polynomial.S) = struct
done
done
done;
(* Backward substitution; 'b' is in the 'nth' column of 'a' *)
let x = Array.copy b in
(* just a fresh array of the right size and type *)
......
src/regexp/automata.ml 0 → 100644
View file @ f3a4e3fd
let print_array p f v = Array.iter (fun x -> p f x) v
let print_list p f v = List.iter (fun x -> p f x) v
type l = char
module Det = struct
type t = { init : int; trans : (l * int) list array; final : bool array }
let print_trans f (a, t) =
Format.fprintf f "@[{@ \"action\":\"%c\",@ \"target\":%i}@]" a t
let print_state f id tr b =
Format.fprintf f
"@[{\"id\":%i,@ \"transition\":[@[%a@]],@ \"is_accepting\":%b}@]" id
(Format.pp_print_list
~pp_sep:(fun _ _ -> Format.fprintf f ",@,")
print_trans)
tr b
let print f t =
Format.fprintf f "{\"statelist\":[@[";
Array.iteri
(fun i l ->
if i > 0 then Format.fprintf f ",@;";
print_state f i l t.final.(i))
t.trans;
Format.fprintf f "@]],@, \"init\":%i}@." t.init
let init_volume a = Array.map (function false -> 0.0 | true -> 1.0) a.final
let iterate_volume a oc =
let n = Array.length a.trans in
let nc = Array.make n 0.0 in
for i = 0 to n - 1 do
nc.(i) <- List.fold_left (fun x (_, s) -> x +. oc.(s)) 0.0 a.trans.(i)
done;
nc
let compute_volume a n =
let t = ref [ init_volume a ] in
for _ = 1 to n do
let v = List.hd !t in
Array.iter
(fun x ->
print_float x;
print_string " ")
v;
print_newline ();
t := iterate_volume a v :: !t
done;
!t
exception Empty
let rec min_list = function
| [] -> raise Empty
| [ t ] -> t
| (_, _, v1) :: (x, y, v2) :: q when v2 < v1 -> min_list ((x, y, v2) :: q)
| t :: _ :: q -> min_list (t :: q)
let rec sample s a = function
| [] -> []
| t :: q ->
let l, s2, _ =
a.trans.(s)
|> List.map (function l, s2 -> (l, s2, t.(s2)))
|> List.map (function l, s2, v ->
(l, s2, -.log (Random.float 1.0) /. v))
|> min_list
in
l :: sample s2 a q
end
module Notdet = struct
module Tr = struct
type t = l * int
let compare t1 t2 = compare t1 t2
end
module TrSet = Set.Make (Tr)
type t = { init : int list; trans : TrSet.t array; final : bool array }
let of_char c =
{
init = [ 0 ];
trans = [| TrSet.singleton (c, 1); TrSet.empty |];
final = [| false; true |];
}
let of_string s =
let n = String.length s in
{
init = [ 0 ];
trans =
Array.init (n + 1) (fun i ->
if i < n then TrSet.singleton (s.[i], i + 1) else TrSet.empty);
final = Array.init (n + 1) (fun i -> i = n);
}
let print f t =
Format.fprintf f "{@[ init=[%a];@.trans=[|%a|];@.final=[|%a|]@]} "
(print_list (fun f x -> Format.fprintf f "%i, " x))
t.init
(print_array (fun f x ->
Format.fprintf f "{";
TrSet.iter (fun (l, i) -> Format.fprintf f "(%c,%i); " l i) x;
Format.fprintf f "}"))
t.trans
(print_array (fun f x -> Format.fprintf f "%b, " x))
t.final
let print_dot f t =
Format.fprintf f "digraph notdet {@[@.%a%a%a@]}"
(fun f a ->
Array.iteri
(fun i x ->
if x then Format.fprintf f "node[shape=doublecircle]; %i;@." i
else Format.fprintf f "node[shape=circle]; %i;@." i)
a)
t.final
(fun f a ->
List.iter
(fun i ->
Format.fprintf f "node[shape=point]; i%i;@.i%i -> %i;@." i i i)
a)
t.init
(fun f a ->
Array.iteri
(fun i x ->
TrSet.iter
(fun (l, j) ->
Format.fprintf f "%i -> %i [label=\"%c\"];@." i j l)
x)
a)
t.trans
let emonde a =
let n = Array.length a.trans in
let compt = Array.make n 0 in
List.iter (fun i -> compt.(i) <- compt.(i) + 1) a.init;
Array.iter
(fun tab -> TrSet.iter (fun (_, j) -> compt.(j) <- compt.(j) + 1) tab)
a.trans;
let n2 = Array.fold_left (fun x y -> if y > 0 then x + 1 else x) 0 compt in
let trans = Array.make n2 TrSet.empty in
let final = Array.make n2 false in
let map = Array.make n 0 in
ignore
@@ Array.fold_left
(fun (i, j) c ->
if c > 0 then (
trans.(i) <- a.trans.(j);
final.(i) <- a.final.(j);
map.(j) <- i;
(i + 1, j + 1) )
else (i, j + 1))
(0, 0) compt;
let init = List.map (fun x -> map.(x)) a.init in
Array.iteri
(fun i tr -> trans.(i) <- TrSet.map (fun (l, j) -> (l, map.(j))) tr)
trans;
{ init; trans; final }
let cat a1 a2 =
let n1 = Array.length a1.trans and n2 = Array.length a2.trans in
let trans =
Array.init (n1 + n2) (fun i ->
if i < n1 then
let p = a1.trans.(i) in
if a1.final.(i) then
List.fold_left
(fun it s ->
TrSet.fold
(fun (l, s2) it2 -> TrSet.add (l, n1 + s2) it2)
a2.trans.(s) it)
p a2.init
else p
else TrSet.map (fun (l, s) -> (l, n1 + s)) a2.trans.(i - n1))
in
let initfinal = List.exists (fun i -> a2.final.(i)) a2.init in
let final =
Array.init (n1 + n2) (fun i ->
if i < n1 then a1.final.(i) && initfinal else a2.final.(i - n1))
in
emonde { init = a1.init; trans; final }
let merge a1 a2 =
let n1 = Array.length a1.trans and n2 = Array.length a2.trans in
{
init = a1.init @ List.map (fun x -> x + n1) a2.init;
trans =
Array.init (n1 + n2) (fun i ->
if i < n1 then a1.trans.(i)
else TrSet.map (fun (l, s) -> (l, s + n1)) a2.trans.(i - n1));
final =
Array.init (n1 + n2) (fun i ->
if i < n1 then a1.final.(i) else a2.final.(i - n1));
}
let star a =
let n = Array.length a.trans in
let trans =
Array.init n (fun i ->
let p = a.trans.(i) in
if a.final.(i) then
List.fold_left
(fun it s ->
TrSet.fold
(fun (l, s2) it2 -> TrSet.add (l, s2) it2)
a.trans.(s) it)
p a.init
else p)
in
let final = Array.copy a.final in
List.iter (fun x -> final.(x) <- true) a.init;
{ a with trans; final }
let plus a = cat a (star a)
let reverse a =
let n = Array.length a.trans in
let init =
snd
@@ Array.fold_left
(fun (i, l) x -> if x then (i + 1, i :: l) else (i + 1, l))
(0, []) a.final
in
let final = Array.make n false in
List.iter (fun i -> final.(i) <- true) a.init;
let trans = Array.make n TrSet.empty in
Array.iteri
(fun i trset ->
TrSet.iter (fun (l, j) -> trans.(j) <- TrSet.add (l, i) trans.(j)) trset)
a.trans;
{ init; trans; final }
module IntSet = Set.Make (struct
type t = int
let compare i j = i - j
end)
let determinize a =
let init = IntSet.of_list a.init in
let set = Hashtbl.create 10 in
Hashtbl.add set init (ref None);
let cmpt = ref 0 in
let to_exp = ref [ init ] in
while !to_exp <> [] do
let ss = List.hd !to_exp in
to_exp := List.tl !to_exp;
let trfun = Hashtbl.create 2 in
IntSet.iter
(fun s ->
TrSet.iter
(fun (l, s2) ->
match Hashtbl.find_opt trfun l with
| None -> Hashtbl.add trfun l (IntSet.singleton s2)
| Some tset -> Hashtbl.replace trfun l (IntSet.add s2 tset))
a.trans.(s))
ss;
Hashtbl.find set ss := Some (trfun, !cmpt);
incr cmpt;
Hashtbl.iter
(fun _ s ->
if not @@ Hashtbl.mem set s then (
Hashtbl.add set s (ref None);
to_exp := s :: !to_exp ))
trfun
done;
let trans = Array.make !cmpt TrSet.empty
and final = Array.make !cmpt false in
Hashtbl.iter
(fun ss x ->
match !x with
| None -> assert false
| Some (trfun, s) ->
let tr =
Hashtbl.fold
(fun l ss2 trset ->
match !(Hashtbl.find set ss2) with
| None -> assert false
| Some (_, c2) -> TrSet.add (l, c2) trset)
trfun TrSet.empty
in
trans.(s) <- tr;
final.(s) <- IntSet.exists (fun x -> a.final.(x)) ss)
set;
{ init = [ 0 ]; trans; final }
let minimize a = determinize @@ reverse @@ determinize @@ reverse a
let to_det a =
let a2 = determinize @@ reverse @@ determinize @@ reverse a in
{
Det.init = List.hd a2.init;
trans =
Array.map (fun tr -> TrSet.fold (fun x l -> x :: l) tr []) a2.trans;
final = a2.final;
}
end
let testa =
let open Det in
{
init = 0;
trans =
[|
[ ('a', 0); ('b', 1) ]; [ ('b', 0); ('a', 2) ]; [ ('a', 1); ('b', 2) ];
|];
final = [| true; false; false |];
}