viewcvs.cgi/types/atoms.ml

open Encodings
module AtomPool  = Pool.Make(Utf8)
type v = AtomPool.t
let value = AtomPool.value
let mk = AtomPool.mk
let mk_ascii s = mk (Utf8.mk s)
let vcompare = AtomPool.compare
let vhash = AtomPool.hash

module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
type t = Finite of unit SList.t | Cofinite of unit SList.t

let empty = Finite []
let any   = Cofinite []

let atom x = Finite [x]

let cup s t =
  match (s,t) with
    | (Finite s, Finite t) -> Finite (SList.cup s t)
    | (Finite s, Cofinite t) -> Cofinite (SList.diff t s)
    | (Cofinite s, Finite t) -> Cofinite (SList.diff s t)
    | (Cofinite s, Cofinite t) -> Cofinite (SList.cap s t)

let cap s t =
  match (s,t) with
    | (Finite s, Finite t) -> Finite (SList.cap s t)
    | (Finite s, Cofinite t) -> Finite (SList.diff s t)
    | (Cofinite s, Finite t) -> Finite (SList.diff t s)
    | (Cofinite s, Cofinite t) -> Cofinite (SList.cup s t)

let diff s t =
  match (s,t) with
    | (Finite s, Cofinite t) -> Finite (SList.cap s t)
    | (Finite s, Finite t) -> Finite (SList.diff s t)
    | (Cofinite s, Cofinite t) -> Finite (SList.diff t s)
    | (Cofinite s, Finite t) -> Cofinite (SList.cup s t)
        
let contains x = function
  | Finite s -> SList.mem s x
  | Cofinite s -> not (SList.mem s x)

let disjoint s t =
  match (s,t) with
    | (Finite s, Finite t) -> SList.disjoint s t
    | (Finite s, Cofinite t) -> SList.subset s t
    | (Cofinite s, Finite t) -> SList.subset t s
    | (Cofinite s, Cofinite t) -> false


let is_empty = function
  | Finite [] -> true
  | _ -> false

let is_atom = function
  | Finite [a] -> Some a
  | _ -> None
      
let sample = function
  | Finite (x :: _) -> x
  | Cofinite l -> AtomPool.dummy_min
  | Finite [] -> raise Not_found

let print_v ppf a = 
  if a = AtomPool.dummy_min then
    Format.fprintf ppf "(almost any atom)"
  else
    Format.fprintf ppf "`%a" Utf8.print (value a)

let print = function
  | Finite l -> List.map (fun x ppf -> print_v ppf x) l
  | Cofinite [] ->
      [ fun ppf -> Format.fprintf ppf "Atom" ]
  | Cofinite [h] ->
      [ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
  | Cofinite (h::t) -> 
      [ fun ppf -> 
          Format.fprintf ppf "@[Atom - (";
          print_v ppf h;
          List.iter (fun x -> Format.fprintf ppf " |@ %a" print_v x) t;
          Format.fprintf ppf ")@]" ]


(* TODO: clean what follow to re-use SList operations *)
let rec hash_seq accu = function
  | t::rem -> hash_seq (accu * 17 + t) rem
  | [] -> accu

let hash accu = function
  | Finite l -> hash_seq (accu + 1) l
  | Cofinite l -> hash_seq (accu + 3) l

let rec equal_rec l1 l2 =
  (l1 == l2) ||
  match (l1,l2) with
    | (x1::l1,x2::l2) -> (x1 == x2) && (equal_rec l1 l2)
    | _ -> false

let equal t1 t2 = match (t1,t2) with
  | (Finite l1, Finite l2) -> equal_rec l1 l2
  | (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
  | _ -> false
  
let rec compare_rec l1 l2 =
  if (l1 == l2) then 0 else
  match (l1,l2) with
    | (x1::l1,x2::l2) ->
        let c = AtomPool.compare x1 x2 in if c <> 0 then c 
        else compare_rec l1 l2
    | ([],_) -> -1
    | _ -> 1

let compare t1 t2 = match (t1,t2) with
  | (Finite l1, Finite l2) -> compare_rec l1 l2
  | (Cofinite l1, Cofinite l2) -> compare_rec l1 l2
  | (Finite _, Cofinite _) -> -1
  | (Cofinite _, Finite _) -> 1

(* Optimize lookup:
   - decision tree
   - merge adjacent segment with same result
*)
type 'a map = (v * 'a) list * 'a option

let mk_map l =
  let rec find_cofinite = function
    | (Cofinite _, x)::_ -> Some x
    | _::rem -> find_cofinite rem
    | [] -> None
  in
  let finites = 
    List.fold_left 
      (fun accu -> function
         | (Cofinite _, _) -> accu
         | (Finite l, x) -> List.fold_left (fun accu a -> (a,x)::accu) accu l)
      [] l
  in
  let finites = 
    List.sort (fun (a1,_) (a2,_) -> AtomPool.compare a1 a2) finites in
  (finites, find_cofinite l)

let get_map v (f,def) =
  let rec aux_def def v = function
    | [] -> def
    | (a,x)::rem ->
        let c = AtomPool.compare a v in
        if c = 0 then x else
          if c < 0 then aux_def def v rem
          else def
  in
  let rec aux_nodef v = function
    | [] -> assert false
    | [a,x] -> x
    | (a,x)::rem ->
        let c = AtomPool.compare a v in
        if c = 0 then x else aux_nodef v rem
  in
  match def with
    | Some def -> aux_def def v f
    | None -> aux_nodef v f


1	abate	374	open Encodings
2			module AtomPool = Pool.Make(Utf8)
3	abate	222	type v = AtomPool.t
4			let value = AtomPool.value
5			let mk = AtomPool.mk
6	abate	374	let mk_ascii s = mk (Utf8.mk s)
7	abate	237	let vcompare = AtomPool.compare
8	abate	271	let vhash = AtomPool.hash
9	abate	222
10	abate	225	module SList = SortedList.Make_transp(SortedList.Lift(AtomPool))
11	abate	224	type t = Finite of unit SList.t \| Cofinite of unit SList.t
12	abate	222
13	abate	1	let empty = Finite []
14	abate	18	let any = Cofinite []
15	abate	1
16			let atom x = Finite [x]
17
18			let cup s t =
19			match (s,t) with
20	abate	224	\| (Finite s, Finite t) -> Finite (SList.cup s t)
21			\| (Finite s, Cofinite t) -> Cofinite (SList.diff t s)
22			\| (Cofinite s, Finite t) -> Cofinite (SList.diff s t)
23			\| (Cofinite s, Cofinite t) -> Cofinite (SList.cap s t)
24	abate	1
25			let cap s t =
26			match (s,t) with
27	abate	224	\| (Finite s, Finite t) -> Finite (SList.cap s t)
28			\| (Finite s, Cofinite t) -> Finite (SList.diff s t)
29			\| (Cofinite s, Finite t) -> Finite (SList.diff t s)
30			\| (Cofinite s, Cofinite t) -> Cofinite (SList.cup s t)
31	abate	1
32			let diff s t =
33			match (s,t) with
34	abate	224	\| (Finite s, Cofinite t) -> Finite (SList.cap s t)
35			\| (Finite s, Finite t) -> Finite (SList.diff s t)
36			\| (Cofinite s, Cofinite t) -> Finite (SList.diff t s)
37			\| (Cofinite s, Finite t) -> Cofinite (SList.cup s t)
38	abate	1
39			let contains x = function
40	abate	224	\| Finite s -> SList.mem s x
41			\| Cofinite s -> not (SList.mem s x)
42	abate	1
43	abate	281	let disjoint s t =
44			match (s,t) with
45			\| (Finite s, Finite t) -> SList.disjoint s t
46			\| (Finite s, Cofinite t) -> SList.subset s t
47			\| (Cofinite s, Finite t) -> SList.subset t s
48			\| (Cofinite s, Cofinite t) -> false
49
50
51	abate	1	let is_empty = function
52			\| Finite [] -> true
53			\| _ -> false
54	abate	110
55			let is_atom = function
56			\| Finite [a] -> Some a
57			\| _ -> None
58	abate	1
59	abate	222	let sample = function
60	abate	1	\| Finite (x :: _) -> x
61	abate	222	\| Cofinite l -> AtomPool.dummy_min
62	abate	1	\| Finite [] -> raise Not_found
63
64	abate	222	let print_v ppf a =
65			if a = AtomPool.dummy_min then
66			Format.fprintf ppf "(almost any atom)"
67			else
68	abate	374	Format.fprintf ppf "`%a" Utf8.print (value a)
69	abate	1
70	abate	222	let print = function
71			\| Finite l -> List.map (fun x ppf -> print_v ppf x) l
72	abate	1	\| Cofinite [] ->
73	abate	222	[ fun ppf -> Format.fprintf ppf "Atom" ]
74	abate	1	\| Cofinite [h] ->
75	abate	222	[ fun ppf -> Format.fprintf ppf "@[Atom - %a@]" print_v h ]
76	abate	1	\| Cofinite (h::t) ->
77			[ fun ppf ->
78	abate	222	Format.fprintf ppf "@[Atom - (";
79			print_v ppf h;
80			List.iter (fun x -> Format.fprintf ppf " \|@ %a" print_v x) t;
81	abate	1	Format.fprintf ppf ")@]" ]
82
83	abate	224
84			(* TODO: clean what follow to re-use SList operations *)
85	abate	222	let rec hash_seq accu = function
86			\| t::rem -> hash_seq (accu * 17 + t) rem
87			\| [] -> accu
88	abate	219
89	abate	222	let hash accu = function
90			\| Finite l -> hash_seq (accu + 1) l
91			\| Cofinite l -> hash_seq (accu + 3) l
92
93			let rec equal_rec l1 l2 =
94			(l1 == l2) \|\|
95			match (l1,l2) with
96			\| (x1::l1,x2::l2) -> (x1 == x2) && (equal_rec l1 l2)
97			\| _ -> false
98
99			let equal t1 t2 = match (t1,t2) with
100			\| (Finite l1, Finite l2) -> equal_rec l1 l2
101			\| (Cofinite l1, Cofinite l2) -> equal_rec l1 l2
102			\| _ -> false
103
104	abate	263	let rec compare_rec l1 l2 =
105			if (l1 == l2) then 0 else
106			match (l1,l2) with
107			\| (x1::l1,x2::l2) ->
108			let c = AtomPool.compare x1 x2 in if c <> 0 then c
109			else compare_rec l1 l2
110			\| ([],_) -> -1
111			\| _ -> 1
112	abate	224
113	abate	263	let compare t1 t2 = match (t1,t2) with
114			\| (Finite l1, Finite l2) -> compare_rec l1 l2
115			\| (Cofinite l1, Cofinite l2) -> compare_rec l1 l2
116			\| (Finite _, Cofinite _) -> -1
117			\| (Cofinite _, Finite _) -> 1
118	abate	243
119	abate	244	(* Optimize lookup:
120			- decision tree
121			- merge adjacent segment with same result
122			*)
123	abate	243	type 'a map = (v * 'a) list * 'a option
124
125			let mk_map l =
126			let rec find_cofinite = function
127			\| (Cofinite _, x)::_ -> Some x
128			\| _::rem -> find_cofinite rem
129			\| [] -> None
130			in
131			let finites =
132			List.fold_left
133			(fun accu -> function
134			\| (Cofinite _, _) -> accu
135			\| (Finite l, x) -> List.fold_left (fun accu a -> (a,x)::accu) accu l)
136			[] l
137			in
138			let finites =
139			List.sort (fun (a1,_) (a2,_) -> AtomPool.compare a1 a2) finites in
140			(finites, find_cofinite l)
141
142			let get_map v (f,def) =
143			let rec aux_def def v = function
144			\| [] -> def
145			\| (a,x)::rem ->
146			let c = AtomPool.compare a v in
147			if c = 0 then x else
148			if c < 0 then aux_def def v rem
149			else def
150			in
151			let rec aux_nodef v = function
152			\| [] -> assert false
153			\| [a,x] -> x
154			\| (a,x)::rem ->
155			let c = AtomPool.compare a v in
156			if c = 0 then x else aux_nodef v rem
157			in
158			match def with
159			\| Some def -> aux_def def v f
160			\| None -> aux_nodef v f
161
162