grew_utils.ml 23.4 KB
Newer Older
pj2m's avatar
pj2m committed
1
open Log
bguillaum's avatar
bguillaum committed
2
open Printf
pj2m's avatar
pj2m committed
3

bguillaum's avatar
bguillaum committed
4
module StringSet = Set.Make (String)
pj2m's avatar
pj2m committed
5 6 7
module StringMap = Map.Make (String)

module IntSet = Set.Make (struct type t = int let compare = Pervasives.compare end)
8 9
module IntMap = Map.Make (struct type t = int let compare = Pervasives.compare end)

10 11


bguillaum's avatar
bguillaum committed
12
let png_file_from_dot dot output_file =
13 14 15 16 17 18 19
  let temp_file_name,out_ch = Filename.open_temp_file ~mode:[Open_rdonly;Open_wronly;Open_text] "grewui_" ".dot" in
  fprintf out_ch "%s" dot;
  close_out out_ch;
  ignore(Sys.command(sprintf "dot -Tpng -o %s %s " output_file temp_file_name))



bguillaum's avatar
bguillaum committed
20 21
(* ================================================================================ *)
module Loc = struct
bguillaum's avatar
bguillaum committed
22
  type t = string * int
bguillaum's avatar
bguillaum committed
23

bguillaum's avatar
bguillaum committed
24
  let to_string (file,line) = sprintf "(file: %s, line: %d)" (Filename.basename file) line
bguillaum's avatar
bguillaum committed
25

bguillaum's avatar
bguillaum committed
26 27 28 29
  let opt_set_line line = function
    | None -> None
    | Some (file,_) -> Some (file, line)

bguillaum's avatar
bguillaum committed
30 31 32 33 34 35 36 37 38 39 40 41
  let opt_to_string = function
    | None -> ""
    | Some x -> to_string x
end (* module Loc *)

(* ================================================================================ *)
module File = struct
  let write data name =
    let out_ch = open_out name in
    fprintf out_ch "%s\n" data;
    close_out out_ch

bguillaum's avatar
bguillaum committed
42
  let read file =
bguillaum's avatar
bguillaum committed
43 44 45 46 47 48 49 50 51
    let in_ch = open_in file in
    let rev_lines = ref [] in
    try
      while true do
        let line = input_line in_ch in
        if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
        then ()
        else rev_lines := line :: !rev_lines
      done; assert false
bguillaum's avatar
bguillaum committed
52
    with End_of_file ->
bguillaum's avatar
bguillaum committed
53 54
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
55

bguillaum's avatar
bguillaum committed
56 57
  (* [read_ln file] returns a list of couples (line_num, line). Blank lines and lines starting with '%' are ignored. *)
  let read_ln file =
bguillaum's avatar
bguillaum committed
58 59 60 61 62 63 64 65 66 67 68
    let in_ch = open_in file in
    let cpt = ref 0 in
    let rev_lines = ref [] in
    try
      while true do
        let line = input_line in_ch in
        incr cpt;
        if (Str.string_match (Str.regexp "^[ \t]*$") line 0) || (line.[0] = '%')
        then ()
        else rev_lines := (!cpt, line) :: !rev_lines
      done; assert false
bguillaum's avatar
bguillaum committed
69
    with End_of_file ->
bguillaum's avatar
bguillaum committed
70 71
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
72 73 74
 end (* module File *)

(* ================================================================================ *)
75
module Pid = struct
bguillaum's avatar
bguillaum committed
76 77 78
  (* type t = int *)
  type t = Pos of int | Neg of int

79
  let compare = Pervasives.compare
bguillaum's avatar
bguillaum committed
80 81 82 83 84 85 86 87

  let to_id = function
    | Pos i -> sprintf "p_%d" i
    | Neg i -> sprintf "n_%d" i

  let to_string = function
    | Pos i -> sprintf "Pos %d" i
    | Neg i -> sprintf "Neg %d" i
bguillaum's avatar
bguillaum committed
88 89 90
end (* module Pid *)

(* ================================================================================ *)
91
module Pid_map =
bguillaum's avatar
bguillaum committed
92
  struct
93
    include Map.Make (Pid)
94

pj2m's avatar
pj2m committed
95
    exception True
bguillaum's avatar
bguillaum committed
96

pj2m's avatar
pj2m committed
97 98
    let exists fct map =
      try
bguillaum's avatar
bguillaum committed
99 100 101
        iter
          (fun key value ->
            if fct key value
102 103 104
            then raise True
          ) map;
        false
pj2m's avatar
pj2m committed
105 106
      with True -> true

bguillaum's avatar
bguillaum committed
107 108
    (* let range key_set m =  *)
    (*   IntSet.fold (fun k s -> (IntSet.add (find k m) s)) key_set IntSet.empty *)
109

bguillaum's avatar
bguillaum committed
110 111
    (* let keys m =  *)
    (*   fold (fun k v s -> (IntSet.add k s)) m IntSet.empty *)
112

bguillaum's avatar
bguillaum committed
113
    (* union of two maps*)
pj2m's avatar
pj2m committed
114
    let union_map m m' = fold (fun k v m'' -> (add k v m'')) m m'
115

bguillaum's avatar
bguillaum committed
116
  end (* module Pid_map *)
pj2m's avatar
pj2m committed
117

bguillaum's avatar
bguillaum committed
118 119 120
(* ================================================================================ *)
module Pid_set = Set.Make (Pid)

bguillaum's avatar
bguillaum committed
121 122
(* ================================================================================ *)
module Gid = struct
123 124 125 126
  type t =
    | Old of int
    | New of int * int (* identifier for "created nodes" *)

bguillaum's avatar
bguillaum committed
127
  let compare = Pervasives.compare
128 129 130 131

  let to_string = function
    | Old i -> sprintf "%d" i
    | New (i,j) -> sprintf"%d__%d" i j
bguillaum's avatar
bguillaum committed
132
end (* module Gid *)
pj2m's avatar
pj2m committed
133

bguillaum's avatar
bguillaum committed
134
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
135
module Gid_map = Map.Make (Gid)
pj2m's avatar
pj2m committed
136

bguillaum's avatar
bguillaum committed
137
(* ================================================================================ *)
pj2m's avatar
pj2m committed
138 139 140
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
141
      (if low > high
pj2m's avatar
pj2m committed
142 143
      then false
      else
144 145 146 147
        match (low+high)/2 with
        | middle when array.(middle) = elt -> true
        | middle when array.(middle) < elt -> loop (middle+1) high
        | middle -> loop low (middle - 1)
bguillaum's avatar
bguillaum committed
148
      ) in
pj2m's avatar
pj2m committed
149 150 151 152 153 154 155 156 157
    loop 0 ((Array.length array) - 1)

  (* dichotomic search in a sorted array *)
  let dicho_find elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when array.(middle) = elt -> middle
      | middle when array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
158
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
159
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
160

pj2m's avatar
pj2m committed
161 162 163 164 165 166
  let dicho_find_assoc elt array =
    let rec loop low high =
      (if low > high then raise Not_found);
      match (low+high)/2 with
      | middle when fst array.(middle) = elt -> middle
      | middle when fst array.(middle) < elt -> loop (middle+1) high
bguillaum's avatar
bguillaum committed
167
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
168
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
169
end (* module Array_ *)
pj2m's avatar
pj2m committed
170

bguillaum's avatar
bguillaum committed
171
(* ================================================================================ *)
pj2m's avatar
pj2m committed
172
module List_ = struct
bguillaum's avatar
bguillaum committed
173 174 175 176 177
  let rec set position elt = function
    | [] -> failwith "List_.set"
    | _::t when position = 0 -> elt::t
    | x::t -> x:: (set (position-1) elt t)

pj2m's avatar
pj2m committed
178 179 180 181 182
  let rec rm elt = function
    | [] -> raise Not_found
    | x::t when x=elt -> t
    | x::t -> x::(rm elt t)

bguillaum's avatar
bguillaum committed
183
  let pos x l =
bguillaum's avatar
bguillaum committed
184 185 186 187 188 189
    let rec loop i = function
    | [] -> None
    | h::t when h=x -> Some i
    | _::t -> loop (i+1) t in
    loop 0 l

pj2m's avatar
pj2m committed
190 191 192 193 194 195 196
  let rec opt = function
    | [] -> []
    | None :: t -> opt t
    | Some x :: t -> x :: (opt t)

  let rec opt_map f = function
    | [] -> []
bguillaum's avatar
bguillaum committed
197
    | x::t ->
198 199 200
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
201 202 203 204 205

  let rec flat_map f = function
    | [] -> []
    | x::t -> (f x)@(flat_map f t)

bguillaum's avatar
bguillaum committed
206 207
  let iteri fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
208 209 210
      | [] -> ()
      | h::t -> (fct i h); (loop (i+1) t) in
    loop 0
bguillaum's avatar
bguillaum committed
211 212 213

  let mapi fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
214 215 216 217
      | [] -> []
      | h::t -> let head = fct i h in head :: (loop (i+1) t)
    in loop 0

bguillaum's avatar
bguillaum committed
218 219
  let opt_mapi fct =
    let rec loop i = function
220 221 222 223 224 225 226
      | [] -> []
      | h::t ->
        match fct i h with
          | None -> loop (i+1) t
          | Some res -> res :: (loop (i+1) t)
    in loop 0

pj2m's avatar
pj2m committed
227
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
228 229
    fst
      (List.fold_left
230 231
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
232 233 234 235 236 237
      )

  let rec remove elt = function
    | [] -> raise Not_found
    | a::tail when a = elt -> tail
    | a::tail -> a::(remove elt tail)
238

pj2m's avatar
pj2m committed
239 240 241
  let to_string string_of_item sep = function
    | [] -> ""
    | h::t -> List.fold_left (fun acc elt -> acc ^ sep ^ (string_of_item elt)) (string_of_item h) t
242

pj2m's avatar
pj2m committed
243 244
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
245
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
246 247 248 249 250 251
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
252
    | h::t (* when elt>h *) -> sort_mem elt t
253 254 255 256 257

  let rec sort_assoc key = function
    | [] -> None
    | (k,_)::_ when key<k -> None
    | (k,_)::t when key>k -> sort_assoc key t
bguillaum's avatar
bguillaum committed
258
    | (_,v)::_ -> Some v
259 260 261 262 263 264 265

  let rec sort_remove_assoc key = function
    | [] -> []
    | (k,_)::_ as t when key<k -> t
    | (k,v)::t when key>k -> (k,v) :: (sort_remove_assoc key t)
    | (_,v)::t -> t

pj2m's avatar
pj2m committed
266 267
  exception Usort

bguillaum's avatar
bguillaum committed
268
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
269 270 271 272 273 274 275 276 277 278 279 280
    | [] -> raise Not_found
    | x::t when key < x -> raise Not_found
    | x::t when key = x -> t
    | x::t -> x::(usort_remove key t)

  let usort_insert ?(compare=Pervasives.compare) elt l =
    let rec loop = function
      | [] -> [elt]
      | x::t when compare elt x < 0 -> elt :: x :: t
      | x::t when compare elt x > 0 -> x :: (loop t)
    | _ -> raise Usort in
    try Some (loop l) with Usort -> None
281

bguillaum's avatar
bguillaum committed
282
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
283 284 285 286
    match (l1,l2) with
    | [], _ | _, [] -> true
    | h1::t1 , h2::t2 when h1<h2 -> sort_disjoint t1 l2
    | h1::t1 , h2::t2 when h1>h2 -> sort_disjoint l1 t2
bguillaum's avatar
bguillaum committed
287
    | _ -> false
288

bguillaum's avatar
bguillaum committed
289
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
290 291 292 293 294
    let rec loop = function
      | [], _ | _, [] -> true
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> false in
bguillaum's avatar
bguillaum committed
295
    loop (l1,l2)
pj2m's avatar
pj2m committed
296

bguillaum's avatar
bguillaum committed
297
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
298 299 300 301 302 303
    let rec loop = function
      | [], _ | _, [] -> []
      | x1::t1, x2::t2 when x1 < x2 -> loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
304 305

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
306 307 308 309 310 311 312 313
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> x2 :: loop (x1::t1, t2)
      | x1::t1, x2::t2 -> x1 :: loop (t1, t2) in
    loop (l1,l2)


pj2m's avatar
pj2m committed
314
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
315
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
316 317 318 319 320 321
    let rec loop = function
      | [], l | l, [] -> l
      | x1::t1, x2::t2 when (compare x1 x2) < 0 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when (compare x1  x2) > 0 -> x2 :: loop (x1::t1, t2)
      | _ -> raise Not_disjoint in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
322 323

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
324 325 326 327 328 329 330
    let rec loop = function
      | [], l -> true
      | l, [] -> false
      | x1::t1, x2::t2 when x1 < x2 -> false
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)
bguillaum's avatar
bguillaum committed
331 332

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
333 334 335 336 337 338 339 340
    let rec loop = function
      | [], l -> failwith "[sort_included_diff] not included"
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> failwith "[sort_included_diff] not included"
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

bguillaum's avatar
bguillaum committed
341
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
342 343 344 345 346 347 348 349
    let rec loop = function
      | [], l -> []
      | l, [] -> l
      | x1::t1, x2::t2 when x1 < x2 -> x1 :: loop (t1, x2::t2)
      | x1::t1, x2::t2 when x1 > x2 -> loop (x1::t1, t2)
      | x1::t1, x2::t2 -> loop (t1, t2) in
    loop (l1,l2)

350
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
351 352
    fst
      (List.fold_left
353 354 355
	 (fun (acc,i) elt -> (f i acc elt, i+1))
	 (init,0) l
      )
bguillaum's avatar
bguillaum committed
356
end (* module List_ *)
pj2m's avatar
pj2m committed
357

bguillaum's avatar
bguillaum committed
358
(* ================================================================================ *)
359 360 361 362
module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
bguillaum's avatar
bguillaum committed
363
  end (* module type OrderedType *)
364

bguillaum's avatar
bguillaum committed
365
(* ================================================================================ *)
366 367 368 369 370 371 372 373
module type S =
  sig
    type key

    type +'a t

    val empty: 'a t

bguillaum's avatar
bguillaum committed
374
    (* an empty list returned if the key is undefined *)
375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399
    val assoc: key -> 'a t -> 'a list

    val is_empty: 'a t -> bool

    val to_string: ('a -> string) -> 'a t -> string

    val iter: (key -> 'a -> unit) -> 'a t -> unit

    val add: key -> 'a -> 'a t -> 'a t option

    val fold: ('b -> key -> 'a -> 'b) -> 'b -> 'a t -> 'b

    (* raise Not_found if no (key,elt) *)
    val remove: key -> 'a -> 'a t -> 'a t

    (* raise Not_found if no (key,elt) *)
    val remove_key: key -> 'a t -> 'a t

    (* [mem key value t ] test if the couple (key, value) is in the massoc [t]. *)
    val mem: key -> 'a -> 'a t -> bool

    (* mem_key key t] tests is [key] is associated to at least one value in [t]. *)
    val mem_key: key -> 'a t -> bool

    exception Not_disjoint
bguillaum's avatar
bguillaum committed
400
    val disjoint_union: 'a t -> 'a t -> 'a t
401 402 403 404 405

    exception Duplicate
    val merge_key: key -> key -> 'a t -> 'a t

    val exists: (key -> 'a -> bool) -> 'a t -> bool
bguillaum's avatar
bguillaum committed
406
  end (* module type S *)
407

bguillaum's avatar
bguillaum committed
408
(* ================================================================================ *)
409 410 411 412 413 414 415 416 417 418 419
module Massoc_make (Ord: OrderedType) = struct
  module M = Map.Make (Ord)

  type key = Ord.t

  type 'a t = ('a list) M.t

  let empty = M.empty

  let is_empty t = (t=empty)

bguillaum's avatar
bguillaum committed
420 421
  let assoc key t =
    try M.find key t
422 423
    with Not_found -> []

bguillaum's avatar
bguillaum committed
424
  let to_string _ _ = failwith "Not implemted"
425 426

  let iter fct t =
bguillaum's avatar
bguillaum committed
427
    M.iter
428 429 430
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

bguillaum's avatar
bguillaum committed
431
  let add key elt t =
432 433
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
434
      match List_.usort_insert elt list with
435 436 437 438 439 440 441
        | Some l -> Some (M.add key l t)
        | None -> None
    with Not_found -> Some (M.add key [elt] t)

  let fold fct init t =
    M.fold
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
442
        List.fold_left
443 444 445 446
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
447

448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464
  (* Not found raised in the value is not defined *)
  let remove key value t =
    match M.find key t with
      | [one] when one=value -> M.remove key t
      | old -> M.add key (List_.usort_remove value old) t

  let rec remove_key key t = M.remove key t

  let rec mem key value t =
    try List_.sort_mem value (M.find key t)
    with Not_found -> false

  let rec mem_key key t = M.mem key t

  exception Not_disjoint

  let disjoint_union t1 t2 =
bguillaum's avatar
bguillaum committed
465
    M.fold
466
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
467
        try
468 469 470 471 472 473 474 475
          let old = M.find key acc in
          M.add key (List_.sort_disjoint_union list old) acc
        with
          | Not_found -> M.add key list acc
          | List_.Not_disjoint -> raise Not_disjoint
      ) t1 t2

  exception Duplicate
bguillaum's avatar
bguillaum committed
476

477 478 479 480 481
  let merge_key i j t =
    try
      let old_i = M.find i t in
      let old_j = try M.find j t with Not_found -> [] in
      M.add j (List_.sort_disjoint_union old_i old_j) (M.remove i t)
bguillaum's avatar
bguillaum committed
482
    with
483 484 485 486 487 488 489 490 491 492
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

  let exists fct t =
    M.exists
      (fun key list ->
        List.exists (fun elt -> fct key elt) list
      ) t
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
493
(* ================================================================================ *)
494
module Massoc_gid = Massoc_make (Gid)
pj2m's avatar
pj2m committed
495

bguillaum's avatar
bguillaum committed
496 497 498
(* ================================================================================ *)
module Massoc_pid = Massoc_make (Pid)

bguillaum's avatar
bguillaum committed
499
(* ================================================================================ *)
pj2m's avatar
pj2m committed
500 501
module Massoc = struct
  (* Massoc is implemented with caml lists *)
bguillaum's avatar
bguillaum committed
502
  (* invariant: we suppose that all 'a list in the structure are not empty! *)
pj2m's avatar
pj2m committed
503
  type 'a t = (int * 'a list) list
504

pj2m's avatar
pj2m committed
505 506 507 508 509 510 511 512 513 514
  let empty = []

  let is_empty t = (t=[])

  let rec assoc key = function
    | [] -> []
    | (h,_)::_ when key<h -> []
    | (h,v)::t when key=h -> v
    | (h,_)::t (* when key>h *) -> assoc key t

bguillaum's avatar
bguillaum committed
515 516 517
  let to_string elt_to_string t =
    List_.to_string
      (fun (i,elt_list) ->
518
        sprintf "%d -> [%s]" i (List_.to_string elt_to_string "," elt_list)
pj2m's avatar
pj2m committed
519
      ) "; " t
bguillaum's avatar
bguillaum committed
520

pj2m's avatar
pj2m committed
521
  let iter fct t =
bguillaum's avatar
bguillaum committed
522
    List.iter
pj2m's avatar
pj2m committed
523
      (fun (key,list) ->
bguillaum's avatar
bguillaum committed
524
        List.iter
525 526
          (fun elt -> fct key elt)
          list
pj2m's avatar
pj2m committed
527
      ) t
528

pj2m's avatar
pj2m committed
529 530
  let rec add key elt = function
    | [] -> Some [(key, [elt])]
bguillaum's avatar
bguillaum committed
531 532
    | (h,list)::t when h=key ->
        (match List_.usort_insert elt list with
533 534 535
        | Some new_list -> Some ((h, new_list)::t)
        | None -> None
        )
pj2m's avatar
pj2m committed
536
    | ((h,_)::_) as t when key<h -> Some ((key,[elt])::t)
bguillaum's avatar
bguillaum committed
537
    | (h,l)::t (* when key>h *) ->
538 539
        match (add key elt t) with Some t' -> Some ((h,l)::t') | None -> None

pj2m's avatar
pj2m committed
540
  let fold_left fct init t =
bguillaum's avatar
bguillaum committed
541
    List.fold_left
pj2m's avatar
pj2m committed
542
      (fun acc (key,list) ->
bguillaum's avatar
bguillaum committed
543
        List.fold_left
544 545 546
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
pj2m's avatar
pj2m committed
547
      init t
548

pj2m's avatar
pj2m committed
549
  let rec remove key value = function
bguillaum's avatar
bguillaum committed
550 551 552
    | [] -> raise Not_found
    | (h,_)::_ when key<h -> raise Not_found
    | (h,[v])::t when key=h && value=v -> t
pj2m's avatar
pj2m committed
553 554 555 556 557
    | (h,list)::t when key=h -> (h,List_.usort_remove value list)::t
    | (h,list)::t (* when key>h *) -> (h,list) :: (remove key value t)

  let rec remove_key key = function
    | [] -> raise Not_found
bguillaum's avatar
bguillaum committed
558
    | (h,_)::_ when key<h -> raise Not_found
pj2m's avatar
pj2m committed
559 560
    | (h,list)::t when key=h -> t
    | (h,list)::t (* when key>h *) -> (h,list) :: (remove_key key t)
561

pj2m's avatar
pj2m committed
562 563 564 565 566 567 568 569 570 571 572 573 574
  let rec mem key value = function
    | [] -> false
    | (h,_)::_ when key<h -> false
    | (h,list)::t when key=h -> List_.sort_mem value list
    | (h,list)::t (* when key>h *) -> mem key value t

  let rec mem_key key = function
    | [] -> false
    | (h,_)::_ when key<h -> false
    | (h,_)::t when key=h -> true
    | (h,_)::t (* when key>h *) -> mem_key key t

  exception Not_disjoint
bguillaum's avatar
bguillaum committed
575
  let disjoint_union t1 t2 =
pj2m's avatar
pj2m committed
576 577 578 579 580
    let rec loop = function
      | [], t | t, [] -> t
      | ((h1,l1)::t1, (h2,l2)::t2) when h1 < h2 -> (h1,l1)::(loop (t1,((h2,l2)::t2)))
      | ((h1,l1)::t1, (h2,l2)::t2) when h1 > h2 -> (h2,l2)::(loop (((h1,l1)::t1),t2))
      | ((h1,l1)::t1, (h2,l2)::t2) (* when h1=h2*) ->
581 582
          try (h1,List_.sort_disjoint_union l1 l2)::(loop (t1, t2))
          with List_.Not_disjoint -> raise Not_disjoint
pj2m's avatar
pj2m committed
583 584 585 586 587 588 589
    in loop (t1, t2)

  exception Duplicate
  let merge_key i j t =
    try
      let i_list = List.assoc i t in
      disjoint_union (remove_key i t) [j,i_list]
bguillaum's avatar
bguillaum committed
590
    with
pj2m's avatar
pj2m committed
591 592 593 594 595
    | Not_found -> (* no key i *) t
    | Not_disjoint -> raise Duplicate


  let exists fct t = List.exists (fun (key,list) -> List.exists (fun value -> fct key value) list) t
596
end (* module Massoc *)
pj2m's avatar
pj2m committed
597

bguillaum's avatar
bguillaum committed
598
(* ================================================================================ *)
pj2m's avatar
pj2m committed
599
module Error = struct
bguillaum's avatar
bguillaum committed
600 601 602 603 604

  exception Build of (string * Loc.t option)
  exception Run of (string * Loc.t option)
  exception Bug of (string * Loc.t option)

bguillaum's avatar
bguillaum committed
605
  let build_ ?loc message =
pj2m's avatar
pj2m committed
606 607 608 609 610 611 612
    Log.fmessage "[%s] %s" (match loc with None -> "?" | Some x -> Loc.to_string x) message;
    raise (Build (message, loc))
  let build ?loc = Printf.ksprintf (build_ ?loc)

  let run_ ?loc message = raise (Run (message, loc))
  let run ?loc = Printf.ksprintf (run_ ?loc)

bguillaum's avatar
bguillaum committed
613 614
  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
bguillaum's avatar
bguillaum committed
615
end (* module Error *)
pj2m's avatar
pj2m committed
616

bguillaum's avatar
bguillaum committed
617
(* ================================================================================ *)
pj2m's avatar
pj2m committed
618 619 620 621 622 623 624 625 626 627 628
module Id = struct
  type name = string

  type t = int

  type table = name array

  let build ?(loc:Loc.t option) string table =
    try Array_.dicho_find string table
    with Not_found -> Error.build ?loc "Identifier '%s' not found" string

bguillaum's avatar
bguillaum committed
629
  let build_opt string table =
pj2m's avatar
pj2m committed
630 631
    try Some (Array_.dicho_find string table)
    with Not_found -> None
bguillaum's avatar
bguillaum committed
632
end (* module Id *)
633

bguillaum's avatar
bguillaum committed
634
(* ================================================================================ *)
635
module Html = struct
bguillaum's avatar
bguillaum committed
636 637
  let css = "<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\n<link rel=\"stylesheet\" href=\"style.css\" type=\"text/css\">"

638 639 640 641 642 643 644 645 646 647 648
  let enter out_ch ?title ?header base_name =
    fprintf out_ch "<html>\n";
    (match title with
    | Some t -> fprintf out_ch "<head>\n%s\n<title>%s</title>\n</head>\n" css t
    | None -> fprintf out_ch "<head>\n%s\n</head>\n" css
    );
    fprintf out_ch "<body>\n";

    (match header with None -> () | Some s -> fprintf out_ch "%s\n" s);

    (match title with
bguillaum's avatar
bguillaum committed
649
    | Some t -> fprintf out_ch "<h1>%s</h1>\n" t
650 651
    | None -> ()
    )
bguillaum's avatar
bguillaum committed
652
  let leave out_ch =
653 654
    fprintf out_ch "</body>\n";
    fprintf out_ch "</html>\n";
bguillaum's avatar
bguillaum committed
655
end  (* module Html *)
656

bguillaum's avatar
bguillaum committed
657
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
658 659
module Conll = struct
  type line = {
bguillaum's avatar
bguillaum committed
660
      line_num: int;
bguillaum's avatar
bguillaum committed
661 662 663 664 665 666 667 668 669
      num: int;
      phon: string;
      lemma: string;
      pos1: string;
      pos2: string;
      morph: (string * string) list;
      gov: int;
      dep_lab: string;
    }
bguillaum's avatar
bguillaum committed
670 671

  let load file =
bguillaum's avatar
bguillaum committed
672

bguillaum's avatar
bguillaum committed
673 674
    let parse_morph line_num = function
      | "_" -> []
bguillaum's avatar
bguillaum committed
675 676 677
      | morph ->
          List.map
            (fun feat ->
bguillaum's avatar
bguillaum committed
678 679 680
              match Str.split (Str.regexp "=") feat with
              | [feat_name] -> (feat_name, "true")
              | [feat_name; feat_value] -> (feat_name, feat_value)
bguillaum's avatar
bguillaum committed
681
              | _ -> Error.build ~loc:(file,line_num) "[Conll.load] illegal morphology \n>>>>>%s<<<<<<" morph
bguillaum's avatar
bguillaum committed
682
            ) (Str.split (Str.regexp "|") morph) in
bguillaum's avatar
bguillaum committed
683

bguillaum's avatar
bguillaum committed
684
    let escape_quote s = Str.global_replace (Str.regexp "\"") "\\\"" s in
bguillaum's avatar
bguillaum committed
685 686

    let parse (line_num, line) =
bguillaum's avatar
bguillaum committed
687
      match Str.split (Str.regexp "\t") line with
bguillaum's avatar
bguillaum committed
688
      | [ num; phon; lemma; pos1; pos2; morph; gov; dep_lab; _; _ ] ->
bguillaum's avatar
bguillaum committed
689 690 691 692 693 694 695 696 697 698
          {line_num = line_num;
           num = int_of_string num;
           phon = escape_quote phon;
           lemma = escape_quote lemma;
           pos1 = pos1;
           pos2 = pos2;
           morph = parse_morph line_num morph;
           gov = int_of_string gov;
           dep_lab = dep_lab;
         }
bguillaum's avatar
bguillaum committed
699
      | l ->
700
          Error.build ~loc:(file,line_num) "[Conll.load] illegal line, %d fields (10 are expected)\n>>>>>%s<<<<<<" (List.length l) line in
bguillaum's avatar
bguillaum committed
701 702 703

    let lines = File.read_ln file in
    List.map parse lines
bguillaum's avatar
bguillaum committed
704
end (* module Conll *)
705

bguillaum's avatar
bguillaum committed
706
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
707
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
708 709 710 711 712 713
module Lex_par = struct

  type item = string list * string list (* first list: pattern parameters $id , second list command parameters @id *)

  type t = item list

714 715 716
  let empty=[]
  let append = List.append

bguillaum's avatar
bguillaum committed
717
  let rm_peripheral_white s =
718 719 720
    Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
    (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)

721

bguillaum's avatar
bguillaum committed
722
  let parse_line ?loc nb_p nb_c line =
723
    let line = rm_peripheral_white line in
724 725 726 727 728 729 730 731 732 733 734 735 736
    if line = "" || line.[0] = '%'
    then None
    else
      match Str.split (Str.regexp "##") line with
        | [args] when nb_c = 0 ->
          (match Str.split (Str.regexp "#") args with
            | l when List.length l = nb_p -> Some (l,[])
            | _ -> Error.bug ?loc
              "Illegal lexical parameter line: \"%s\" doesn't contain %d args"
              line nb_p)
        | [args; values] ->
          (match (Str.split (Str.regexp "#") args, Str.split (Str.regexp "#") values) with
            | (lp,lc) when List.length lp = nb_p && List.length lc = nb_c -> Some (lp,lc)
bguillaum's avatar
bguillaum committed
737
            | _ -> Error.bug ?loc
738 739 740
              "Illegal lexical parameter line: \"%s\" doesn't contain %d args and %d values"
              line nb_p nb_c)
        | _ -> Error.bug ?loc "Illegal param line: '%s'" line
bguillaum's avatar
bguillaum committed
741

742
  let from_lines ?loc nb_p nb_c lines = List_.opt_map (parse_line ?loc nb_p nb_c) lines
743

744
  let load ?loc dir nb_p nb_c file =
745
    try
bguillaum's avatar
bguillaum committed
746
      let full_file =
747 748 749 750
        if Filename.is_relative file
        then Filename.concat dir file
        else file in
      let lines = File.read full_file in
751
      List_.opt_mapi (fun i line -> parse_line ~loc:(full_file,i) nb_p nb_c line) lines
752 753
    with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file

bguillaum's avatar
bguillaum committed
754 755 756
  let sub x y = List.mem x (Str.split (Str.regexp "|") y)

  let filter index atom t =
bguillaum's avatar
bguillaum committed
757
    match
bguillaum's avatar
bguillaum committed
758 759 760
      List_.opt_map
        (fun (p_par, c_par) ->
          let par = List.nth p_par index in
bguillaum's avatar
bguillaum committed
761
          if atom=par
bguillaum's avatar
bguillaum committed
762 763 764 765 766 767
          then Some (p_par, c_par)
          else
            if sub atom par (* atom is one of the values of the disjunction par *)
            then Some (List_.set index atom p_par, c_par)
            else None
        ) t
bguillaum's avatar
bguillaum committed
768
    with
769
    | [] -> None
bguillaum's avatar
bguillaum committed
770
    | t -> Some t
bguillaum's avatar
bguillaum committed
771 772 773 774 775

  let get_param_value index = function
    | [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
    | (params,_)::_ -> List.nth params index

776 777 778
  let get_command_value index = function
    | [(_,one)] -> List.nth one index
    | [] -> Error.bug "[Lex_par.get_command_value] empty parameter"
bguillaum's avatar
bguillaum committed
779 780 781 782 783 784
    | (_,[sing])::tail when index=0 ->
        Printf.sprintf "%s/%s"
          sing
          (List_.to_string
             (function
               | (_,[s]) -> s
bguillaum's avatar
bguillaum committed
785 786 787
               | _ -> Error.bug "[Lex_par.get_command_value] inconsistent param"
             ) "/" tail
          )
788
    | l -> Error.run "Lexical parameter are not functionnal"
789

bguillaum's avatar
bguillaum committed
790
end (* module Lex_par *)
791

bguillaum's avatar
bguillaum committed
792
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
793 794 795
(* copy from leopar *)
module Timeout = struct
  exception Stop
796

bguillaum's avatar
bguillaum committed
797 798
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
799

bguillaum's avatar
bguillaum committed
800 801 802
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
803
    match !timeout with
bguillaum's avatar
bguillaum committed
804 805 806 807
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
808
end (* module Timeout *)