Skip to content

GitLab

Commit 0ade6a62 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2002-10-31 17:52:39 by cvscast] Empty log message 

Original author: cvscast
Date: 2002-10-31 17:53:17+00:00
parent 99dc9a24
Hide whitespace changes
Inline Side-by-side
types/sequence.ml
View file @ 0ade6a62
......@@ -6,15 +6,15 @@ let decompose t =
Types.Product.get t)
module V = Types.Positive
module H = Types.DescrHash
module H = Types.DescrMap
let mapping f t queue =
let memo = H.create 13 in
let memo = ref H.empty in
let rec aux t =
try H.find memo t
try H.find t !memo
with Not_found ->
let v = V.forward () in
H.add memo t v;
memo := H.add t v !memo;
let (has_nil,rect) = decompose t in
let l = List.map (fun (t1,t2) -> f t1 (aux t2)) rect in
let l = if has_nil then queue :: l else l in
......@@ -50,12 +50,12 @@ let plus t = let t = Types.cons t in Types.times t (star_node t)
let string = star (Types.Char.any)
let approx t =
let memo = H.create 13 in
let memo = ref H.empty in
let res = ref Types.empty in
let rec aux t =
try H.find memo t
try H.find t !memo
with Not_found ->
H.add memo t ();
memo := H.add t () !memo;
let rect = Types.Product.get t in
List.iter (fun (t1,t2) -> res := Types.cup t1 !res; aux t2) rect;
in
......
types/strings.ml deleted 100644 → 0
View file @ 99dc9a24
open Recursive
module I = struct
type 'a t = {
final : bool;
trans : (int * int * ('a Boolean.t)) list;
}
let rec prepare = function
| (i,j,[])::r -> prepare r
| (i1,j1,t1)::(i2,j2,t2)::r when (j1+1=i2) && (t1=t2) ->
prepare ((i1,j2,t1)::r)
| (i,j,t)::r -> (i,j,t)::(prepare r)
| [] -> []
let mk final trans =
{ final = final; trans = prepare trans }
let rec equal_aux e l1 l2 =
match (l1,l2) with
| ((i1,j1,t1)::r1, (i2,j2,t2)::r2) when i1 = i2 && j1 = j2 ->
Boolean.equal e t1 t2; equal_aux e r1 r2
| _ -> raise NotEqual
let equal e a b =
if (a.final <> b.final) then raise NotEqual;
equal_aux e a.trans b.trans
let rec map_aux f = function
| [] -> []
| (i,j,t)::r -> (i,j,Boolean.map f t)::(map_aux f r)
let map f a =
mk a.final (map_aux f a.trans)
let hash h a =
Hashtbl.hash (map h a)
let iter f a =
ignore (map f a)
let deep = 4
end
module Algebra = Recursive.Make(I)
open I
open Algebra
let empty = { final = false; trans = [] }
let any = { final = true; trans = [(0,255, Boolean.full)] }
let final = { empty with final = true }
let trans i j t = { empty with trans = [(i,j, Boolean.atom t)] }
let rec binary_op f l1 l2 =
match (l1,l2) with
| ((i1,j1,t1)::r1, (i2,j2,t2)::r2) ->
if (j1 < i2) then
(i1,j1, f t1 Boolean.empty)::(binary_op f r1 l2)
else if (j2 < i1) then
(i2, j2, f Boolean.empty t2)::(binary_op f l1 r2)
else if (i1 < i2) then
(i1, i2-1, f t1 Boolean.empty)::(binary_op f ((i2,j1,t1)::r1) l2)
else if (i2 < i1) then
(i2, i1-1, f Boolean.empty t2)::(binary_op f l1 ((i1,j2,t2)::r2))
else if (j1 < j2) then
(i1, j1, f t1 t2)::(binary_op f r1 ((j1+1,j2,t2)::r2))
else if (j2 < j1) then
(i2, j2, f t1 t2)::(binary_op f ((j2+1,j1,t1)::r1) r2)
else
(i1,j1, f t1 t2)::(binary_op f r1 r2)
| (i1,j1,t1)::r1, [] ->
(i1,j1,f t1 Boolean.empty)::(binary_op f r1 [])
| [], (i2,j2,t2)::r2 ->
(i2,j2,f Boolean.empty t2)::(binary_op f [] r2)
| [],[] ->
[]
let cup x y =
mk
(x.final || y.final)
(binary_op Boolean.cup x.trans y.trans)
let cap x y =
mk
(x.final && y.final)
(binary_op Boolean.cap x.trans y.trans)
let diff x y =
mk
(x.final && not y.final)
(binary_op Boolean.diff x.trans y.trans)
let cons d =
let n = make () in
define n d;
n
type t = descr
let bool lines =
List.fold_left
(fun acc (p,n) ->
let l = List.fold_left (fun a t -> cap a (descr t)) any p in
let l = List.fold_left (fun a t -> diff a (descr t)) l n in
cup acc l
)
empty
lines
(*
let dump d =
Printf.eprintf "{ final = %b; trans = " d.final;
List.iter (fun (c,[[t],[]]) -> Printf.eprintf "(%c,%i); " c (id t)) d.trans;
Printf.eprintf "}\n";
flush stderr
*)
module TSet = Set.Make(struct type t = descr let compare = compare end)
module TMap = Map.Make(struct type t = descr let compare = compare end)
let memo = ref TSet.empty
let rec rec_empty d =
if TSet.mem d !memo then ()
else if d.final then raise Exit
else
(
memo := TSet.add d !memo;
List.iter (fun (i,j,lines) -> rec_empty (bool lines)) d.trans
)
let is_empty d =
let backup = !memo in
try rec_empty d; true
with Exit -> memo := backup; false
let rec rec_sample memo d buf =
if d.final then ()
else
let rec aux = function
| [] -> raise Not_found
| (i,j,lines) :: r ->
let d' = bool lines in
if (TSet.mem d' memo) || (is_empty d')
then aux r
else (Buffer.add_char buf (Char.chr i);
rec_sample (TSet.add d' memo) d' buf)
in
aux d.trans
let sample d =
let buf = Buffer.create 64 in
rec_sample TSet.empty d buf;
Buffer.contents buf
let normal x =
List.map (fun (i,j,lines) -> (i,j,bool lines)) x.trans
let memo_concat = ref TMap.empty
let rec rec_concat x y =
(try TMap.find x !memo_concat
with Not_found ->
let r = make () in
memo_concat := TMap.add x r !memo_concat;
define r (compute_concat x y);
r)
and compute_concat x y =
let tr =
List.map
(fun (i,j,t) -> (i,j, Boolean.atom (rec_concat (bool t) y)))
x.trans in
let d = mk false tr in
if x.final then cup y d else d
let concat x y =
let r = compute_concat x y in
memo_concat := TMap.empty;
internalize_descr r
(* Note: another implementation of concat:
let concat x y
Regexp.compile (`Seq (Regexp.decompile x, Regexp.decompile y))
*)
module Regexp =
struct
type regexp =
[ `Eps
| `Nothing
| `Char of int * int
| `Seq of regexp * regexp
| `Alt of regexp * regexp
| `Star of regexp
]
let rec prepare = function
| `Char (i,j) when i = j -> `String (Char.escaped (Char.chr i))
| `Char (i,j) -> `Char [(i,j)]
| `Seq (r1,r2) ->
(match (prepare r1, prepare r2) with
| `String s1, `String s2 -> `String (s1 ^ s2)
| `Seq (a,`String s1), `String s2 -> `Seq (a, `String (s1^s2))
| `String s1, `Seq (`String s2,b) -> `Seq (`String (s1^s2),b)
| `Seq (a,`String s1), `Seq (`String s2,b) ->
`Seq (a, `Seq(`String (s1^s2),b))
| `Eps,r | r,`Eps -> r
| `Nothing,_ | _,`Nothing -> `Nothing
| r1,r2 -> `Seq (r1,r2)
)
| `Alt (r1,r2) ->
(match (prepare r1, prepare r2) with
| `Nothing,r | r,`Nothing -> r
| `Eps, `Eps -> `Eps
| `Eps,r | r,`Eps -> `Opt r
| `Char l1, `Char l2 -> `Char (Intervals.cup l1 l2)
| `Opt r1, `Opt r2 -> `Opt (`Alt (r1,r2))
| `Opt r1, r2 | r1, `Opt r2 -> `Opt (`Alt (r1,r2))
| r1,r2 -> `Alt (r1,r2)
)
| `Nothing -> `Nothing
| `Eps -> `Eps
| `Star r ->
(match prepare r with
| `Nothing | `Eps -> `Eps
| `Star r | `Opt r -> `Star r
| r -> `Star r
)
(*
let rec print ppf = function
| `Seq (r1,r2) -> Format.fprintf ppf "%a %a" print r1 print r2
| `Alt (r1,r2) -> Format.fprintf ppf "%a | %a" print r1 print r2
| `Eps -> ()
| `Star r -> Format.fprintf ppf "(%a)*" print r
| `Char (i,j) ->
if i = j then Format.fprintf ppf "%C" (Char.chr i)
else Format.fprintf ppf "[%C-%C]" (Char.chr i) (Char.chr j)
| `Nothing -> Format.fprintf ppf "(NOTHING)"
*)
let rec print ppf = function
| `Nothing -> Format.fprintf ppf "(NOTHING)"
| `Eps -> ()
| `Alt (r1,r2) -> Format.fprintf ppf "(%a | %a)" print r1 print r2
| `Seq (r1,r2) -> Format.fprintf ppf "%a %a" print r1 print r2
| `Opt r -> Format.fprintf ppf "(%a)?" print r
| `Star r -> Format.fprintf ppf "(%a)*" print r
| `Char [(0,255)] -> Format.fprintf ppf "."
| `Char l ->
Format.fprintf ppf "[";
List.iter
(fun (i,j) -> Format.fprintf ppf "%C-%C" (Char.chr i) (Char.chr j))
l;
Format.fprintf ppf "]"
| `String s ->
Format.fprintf ppf "%S" s
let print r =
match prepare r with
| `Nothing -> []
| r -> [ fun ppf -> Format.fprintf ppf "/ %a /" print r ]
let chr c =
`Char (Char.code c, Char.code c)
let str s =
let r = ref `Eps in
for i = (String.length s - 1) downto 0 do
r := `Seq (chr s.[i], !r)
done;
!r
let memo = Hashtbl.create 51
let rec compile e seq =
if List.mem seq e then empty
else
let e = seq :: e in
match seq with
| [] -> final
| `Eps :: rest -> compile e rest
| `Nothing :: rest -> empty
| `Char (i,j) :: rest -> trans i j (guard_compile rest)
| `Seq (r1,r2) :: rest -> compile e (r1 :: r2 :: rest)
| `Alt (r1,r2) :: rest -> cup (compile e (r1::rest)) (compile e (r2::rest))
| `Star r :: rest -> cup (compile e rest) (compile e (r::seq))
and guard_compile seq =
try Hashtbl.find memo seq
with
Not_found ->
let n = make () in
Hashtbl.add memo seq n;
define n (compile [] seq);
n
let compile regexp =
let n = compile [] [regexp] in
let n = internalize_descr n in
Hashtbl.clear memo;
n
let alt x y =
match (x,y) with
| `Nothing, _ -> y
| _, `Nothing -> x
| `Seq (a1, `Seq (`Star (`Seq (b2,a2)), b1)), `Eps
| `Eps, `Seq (a1, `Seq (`Star (`Seq (b2,a2)), b1))
when a1 = a2 && b1 = b2 -> `Star (`Seq (a1,b1))
| _ -> `Alt (x,y)
let star = function
| `Nothing | `Eps -> `Eps
| x -> `Star x
let seq x y =
match (x,y) with
| `Nothing, _ -> `Nothing
| _, `Nothing -> `Nothing
| `Eps, _ -> y
| _, `Eps -> x
| _ -> `Seq (x,y)
(* XXX: use (regexp TMap.t) instead of (regexp * t) list ? *)
let rec decompile (seen : TSet.t) x : (regexp * (regexp * t) list) =
(* decompile x into
r | (r1 x1) | ... | (rn xn)
where the xi belong to seen
*)
let seen' = TSet.add x seen in
let esc = ref (if x.final then `Eps else `Nothing) in
let st = ref `Nothing in
let up = ref ([] : (regexp * t) list) in
List.iter
(fun (i,j,t) ->
let y = bool t in
let prefix = `Char (i,j) in
if x = y then st := alt prefix !st
else if TSet.mem y seen then up := (prefix, y) :: !up
else
let (esc',tr) = decompile seen' y in
esc := alt (seq prefix esc') !esc;
List.iter
(fun (re,z) ->
if z = x then st := alt (seq prefix re) !st
else up := (seq prefix re, z) :: !up
) tr
) x.trans;
let st = star !st in
(seq st !esc, List.map (fun (re,z) -> (seq st re), z) !up)
let decompile x =
let (esc,tr) = decompile TSet.empty x in
assert (tr = []);
esc
end
let print x =
Regexp.print (Regexp.decompile x)
(*
open Strings;;
let t1 = diff any (compile (Star (Char 'a')));;
let t2 = compile (Char 'b');;
let t3 = concat t1 t2;;
*)
types/strings.mli deleted 100644 → 0
View file @ 99dc9a24
(*
module I :
sig
type 'a t = { final : bool; trans : (int * int * 'a Boolean.t) list; }
end
module Algebra :
sig
type node
val descr : node -> node I.t
end
type t = Algebra.node I.t
val bool : Algebra.node Boolean.t -> t
*)
type t
(** Boolean connectives **)
val cup : t -> t -> t
val cap : t -> t -> t
val diff : t -> t -> t
val empty : t
val any : t
(** Operators **)
val concat : t -> t -> t
(** Compiling from regexp **)
module Regexp: sig
type regexp =
[ `Eps
| `Nothing
| `Char of int * int
| `Seq of regexp * regexp
| `Alt of regexp * regexp
| `Star of regexp ]
val chr : char -> regexp
val str : string -> regexp
val compile : regexp -> t
val decompile : t -> regexp
end
(** Subtyping **)
val is_empty : t -> bool
val sample : t -> string
val print: t -> (Format.formatter -> unit) list
types/types.ml
View file @ 0ade6a62
......@@ -542,7 +542,7 @@ module DescrHash =
end
)
module MapDescr = Map.Make(struct type t = descr let compare = compare end)
module DescrMap = Map.Make(struct type t = descr let compare = compare end)
let memo_normalize = DescrHash.create 17
......
types/types.mli
View file @ 0ade6a62
......@@ -21,6 +21,10 @@ val hash_descr: descr -> int
module DescrHash: Hashtbl.S with type key = descr
module DescrMap: Map.S with type key = descr
(* Note: it seems that even for non-functional data, DescrMap
is more efficient than DescrHash ... *)
(** Boolean connectives **)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment