Attention une mise à jour du serveur va être effectuée le vendredi 16 avril entre 12h et 12h30. Cette mise à jour va générer une interruption du service de quelques minutes.

grew_utils.ml 22.3 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)

bguillaum's avatar
bguillaum committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
(* ================================================================================ *)
module Loc = struct
  type t = string * int

  let to_string (file,line) = sprintf "(file: %s, line: %d)" (Filename.basename file) line

  let opt_set_line line = function
    | None -> None
    | Some (file,_) -> Some (file, line)

  let opt_to_string = function
    | None -> ""
    | Some x -> to_string x
end (* module Loc *)

(* ================================================================================ *)
module Error = struct

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

  let build_ ?loc message =
    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)

  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
end (* module Error *)
43

bguillaum's avatar
bguillaum committed
44 45 46 47 48
(* ================================================================================ *)
module String_ = struct

  let to_float string =
    try float_of_string string
bguillaum's avatar
bguillaum committed
49 50 51
    with _ ->
      try float_of_string (Str.global_replace (Str.regexp "\\.") "," string)
      with _ -> Error.build "[String_.to_float] cannot convert '%s'" string
52

bguillaum's avatar
bguillaum committed
53
  let of_float float = Str.global_replace (Str.regexp ",") "." (sprintf "%g" float)
54

bguillaum's avatar
bguillaum committed
55
end (* module String_ *)
56

bguillaum's avatar
bguillaum committed
57 58 59 60 61 62 63 64
(* ================================================================================ *)
module Dot = struct
  let to_png_file dot output_file =
    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))
end (* module Dot *)
65

bguillaum's avatar
bguillaum committed
66 67 68 69 70 71 72 73

(* ================================================================================ *)
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
74
  let read file =
bguillaum's avatar
bguillaum committed
75 76 77 78 79 80 81 82 83
    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
84
    with End_of_file ->
bguillaum's avatar
bguillaum committed
85 86
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
87

bguillaum's avatar
bguillaum committed
88 89
  (* [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
90 91 92 93 94 95 96 97 98 99 100
    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
101
    with End_of_file ->
bguillaum's avatar
bguillaum committed
102 103
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
104 105 106
 end (* module File *)

(* ================================================================================ *)
107
module Pid = struct
bguillaum's avatar
bguillaum committed
108 109 110
  (* type t = int *)
  type t = Pos of int | Neg of int

111
  let compare = Pervasives.compare
bguillaum's avatar
bguillaum committed
112 113 114 115 116 117 118 119

  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
120 121 122
end (* module Pid *)

(* ================================================================================ *)
123
module Pid_map =
bguillaum's avatar
bguillaum committed
124
  struct
125
    include Map.Make (Pid)
126

pj2m's avatar
pj2m committed
127
    exception True
bguillaum's avatar
bguillaum committed
128

pj2m's avatar
pj2m committed
129 130
    let exists fct map =
      try
bguillaum's avatar
bguillaum committed
131 132 133
        iter
          (fun key value ->
            if fct key value
134 135 136
            then raise True
          ) map;
        false
pj2m's avatar
pj2m committed
137 138
      with True -> true

bguillaum's avatar
bguillaum committed
139 140
    (* let range key_set m =  *)
    (*   IntSet.fold (fun k s -> (IntSet.add (find k m) s)) key_set IntSet.empty *)
141

bguillaum's avatar
bguillaum committed
142 143
    (* let keys m =  *)
    (*   fold (fun k v s -> (IntSet.add k s)) m IntSet.empty *)
144

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

bguillaum's avatar
bguillaum committed
148
  end (* module Pid_map *)
pj2m's avatar
pj2m committed
149

bguillaum's avatar
bguillaum committed
150 151 152
(* ================================================================================ *)
module Pid_set = Set.Make (Pid)

bguillaum's avatar
bguillaum committed
153 154
(* ================================================================================ *)
module Gid = struct
155 156
  type t =
    | Old of int
157
    | New of (int * int) (* identifier for "created nodes" *)
158

bguillaum's avatar
bguillaum committed
159
  (* a compare function which ensures that new nodes are at the "end" of the graph *)
160 161 162 163 164
  let compare t1 t2 = match (t1,t2) with
    | Old _ , New _ -> -1
    | New _, Old _ -> 1
    | Old o1, Old o2 -> Pervasives.compare o1 o2
    | New n1, New n2 -> Pervasives.compare n1 n2
165 166 167 168

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

bguillaum's avatar
bguillaum committed
171
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
172
module Gid_map = Map.Make (Gid)
pj2m's avatar
pj2m committed
173

bguillaum's avatar
bguillaum committed
174
(* ================================================================================ *)
pj2m's avatar
pj2m committed
175 176 177
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
178
      (if low > high
pj2m's avatar
pj2m committed
179 180
      then false
      else
181 182 183 184
        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
185
      ) in
pj2m's avatar
pj2m committed
186 187 188 189 190 191 192 193 194
    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
195
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
196
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
197

pj2m's avatar
pj2m committed
198 199 200 201 202 203
  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
204
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
205
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
206
end (* module Array_ *)
pj2m's avatar
pj2m committed
207

bguillaum's avatar
bguillaum committed
208
(* ================================================================================ *)
pj2m's avatar
pj2m committed
209
module List_ = struct
bguillaum's avatar
bguillaum committed
210 211 212 213 214
  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
215 216 217 218 219
  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
220
  let pos x l =
bguillaum's avatar
bguillaum committed
221 222 223 224 225 226
    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
227 228 229 230 231 232 233
  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
234
    | x::t ->
235 236 237
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
238 239 240 241 242

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

bguillaum's avatar
bguillaum committed
243 244
  let iteri fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
245 246 247
      | [] -> ()
      | h::t -> (fct i h); (loop (i+1) t) in
    loop 0
bguillaum's avatar
bguillaum committed
248 249 250

  let mapi fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
251 252 253 254
      | [] -> []
      | h::t -> let head = fct i h in head :: (loop (i+1) t)
    in loop 0

bguillaum's avatar
bguillaum committed
255 256
  let opt_mapi fct =
    let rec loop i = function
257 258 259 260 261 262 263
      | [] -> []
      | 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
264
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
265 266
    fst
      (List.fold_left
267 268
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
269 270 271 272 273 274
      )

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

pj2m's avatar
pj2m committed
276 277 278
  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
279

pj2m's avatar
pj2m committed
280 281
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
282
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
283 284 285 286 287 288
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
289
    | h::t (* when elt>h *) -> sort_mem elt t
290 291 292 293 294

  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
295
    | (_,v)::_ -> Some v
296 297 298 299 300 301 302

  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
303 304
  exception Usort

bguillaum's avatar
bguillaum committed
305
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
306 307 308 309 310 311 312 313 314 315 316 317
    | [] -> 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
318

bguillaum's avatar
bguillaum committed
319
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
320 321 322 323
    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
324
    | _ -> false
325

bguillaum's avatar
bguillaum committed
326
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
327 328 329 330 331
    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
332
    loop (l1,l2)
pj2m's avatar
pj2m committed
333

bguillaum's avatar
bguillaum committed
334
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
335 336 337 338 339 340
    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
341 342

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
343 344 345 346 347 348 349 350
    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
351
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
352
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
353 354 355 356 357 358
    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
359 360

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
361 362 363 364 365 366 367
    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
368 369

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
370 371 372 373 374 375 376 377
    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
378
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
379 380 381 382 383 384 385 386
    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)

387
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
388 389
    fst
      (List.fold_left
390 391
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
392
      )
bguillaum's avatar
bguillaum committed
393
end (* module List_ *)
pj2m's avatar
pj2m committed
394

bguillaum's avatar
bguillaum committed
395
(* ================================================================================ *)
396 397 398 399
module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
bguillaum's avatar
bguillaum committed
400
  end (* module type OrderedType *)
401

bguillaum's avatar
bguillaum committed
402
(* ================================================================================ *)
403 404 405 406 407 408 409 410
module type S =
  sig
    type key

    type +'a t

    val empty: 'a t

bguillaum's avatar
bguillaum committed
411
    (* an empty list returned if the key is undefined *)
412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436
    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
437
    val disjoint_union: 'a t -> 'a t -> 'a t
438 439 440 441 442

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

    val exists: (key -> 'a -> bool) -> 'a t -> bool
443 444

    val rename: (key * key) list -> 'a t -> 'a t
bguillaum's avatar
bguillaum committed
445
  end (* module type S *)
446

bguillaum's avatar
bguillaum committed
447
(* ================================================================================ *)
448 449 450 451 452 453 454 455 456 457 458
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
459 460
  let assoc key t =
    try M.find key t
461 462
    with Not_found -> []

bguillaum's avatar
bguillaum committed
463
  let to_string _ _ = failwith "Not implemted"
464 465

  let iter fct t =
bguillaum's avatar
bguillaum committed
466
    M.iter
467 468 469
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

bguillaum's avatar
bguillaum committed
470
  let add key elt t =
471 472
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
473
      match List_.usort_insert elt list with
474 475 476 477 478 479 480
        | 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
481
        List.fold_left
482 483 484 485
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
486

487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503
  (* 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
504
    M.fold
505
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
506
        try
507 508 509 510 511 512 513 514
          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
515

516 517 518 519 520
  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
521
    with
522 523 524
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
525 526
(* New implementation of exists but exists fct not implemented in ocaml < 3.12 *)
(*
527 528 529 530 531
  let exists fct t =
    M.exists
      (fun key list ->
        List.exists (fun elt -> fct key elt) list
      ) t
bguillaum's avatar
bguillaum committed
532 533 534 535 536 537 538 539 540 541 542 543 544
*)

  exception True
  let exists fct t =
    try
      M.iter
        (fun key list ->
          if List.exists (fun elt -> fct key elt) list
          then raise True
        ) t;
      false
    with True -> true

545 546 547 548 549 550 551
  let rename mapping t =
    M.fold
      (fun key value acc ->
        let new_key = try List.assoc key mapping with Not_found -> key in
        M.add new_key value acc
      ) t M.empty

552 553
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
554
(* ================================================================================ *)
555
module Massoc_gid = Massoc_make (Gid)
pj2m's avatar
pj2m committed
556

bguillaum's avatar
bguillaum committed
557 558 559
(* ================================================================================ *)
module Massoc_pid = Massoc_make (Pid)

pj2m's avatar
pj2m committed
560

bguillaum's avatar
bguillaum committed
561
(* ================================================================================ *)
pj2m's avatar
pj2m committed
562 563 564 565 566 567 568 569 570 571 572
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
573
  let build_opt string table =
pj2m's avatar
pj2m committed
574 575
    try Some (Array_.dicho_find string table)
    with Not_found -> None
bguillaum's avatar
bguillaum committed
576
end (* module Id *)
577

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

582 583 584 585 586 587 588 589 590 591 592
  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
593
    | Some t -> fprintf out_ch "<h1>%s</h1>\n" t
594 595
    | None -> ()
    )
bguillaum's avatar
bguillaum committed
596
  let leave out_ch =
597 598
    fprintf out_ch "</body>\n";
    fprintf out_ch "</html>\n";
bguillaum's avatar
bguillaum committed
599
end  (* module Html *)
600

bguillaum's avatar
bguillaum committed
601
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
602 603
module Conll = struct
  type line = {
bguillaum's avatar
bguillaum committed
604
      line_num: int;
bguillaum's avatar
bguillaum committed
605
      num: string;
bguillaum's avatar
bguillaum committed
606 607 608 609 610
      phon: string;
      lemma: string;
      pos1: string;
      pos2: string;
      morph: (string * string) list;
bguillaum's avatar
bguillaum committed
611
      deps: (string * string ) list;
bguillaum's avatar
bguillaum committed
612
    }
bguillaum's avatar
bguillaum committed
613

bguillaum's avatar
bguillaum committed
614
  let root = { line_num = -1; num="0"; phon="ROOT"; lemma="__"; pos1="_X"; pos2=""; morph=[]; deps=[] }
bguillaum's avatar
bguillaum committed
615

bguillaum's avatar
bguillaum committed
616 617 618 619 620 621 622 623 624 625 626 627 628 629
  let parse_morph file_name line_num = function
    | "_" -> []
    | morph ->
      List.map
        (fun feat ->
          match Str.split (Str.regexp "=") feat with
            | [feat_name] -> (feat_name, "true")
            | [feat_name; feat_value] -> (feat_name, feat_value)
            | _ -> Error.build ~loc:(file_name,line_num) "[Conll.load] illegal morphology \n>>>>>%s<<<<<<" morph
        ) (Str.split (Str.regexp "|") morph)

  let underscore s = if s = "" then "_" else s
  let parse_line file_name (line_num, line) =
    try
bguillaum's avatar
bguillaum committed
630
      match Str.split (Str.regexp "\t") line with
bguillaum's avatar
bguillaum committed
631 632 633 634
        | [ num; phon; lemma; pos1; pos2; morph; govs; dep_labs; _; _ ] ->
          let gov_list = if govs = "_" then [] else Str.split (Str.regexp "|") govs
          and lab_list = if dep_labs = "_" then [] else Str.split (Str.regexp "|") dep_labs in
          let deps = List.combine gov_list lab_list in
bguillaum's avatar
bguillaum committed
635
          {line_num = line_num;
bguillaum's avatar
bguillaum committed
636
           num = num;
bguillaum's avatar
bguillaum committed
637 638 639 640 641
           phon = underscore phon;
           lemma = underscore lemma;
           pos1 = underscore pos1;
           pos2 = underscore pos2;
           morph = parse_morph file_name line_num morph;
642
           deps = deps;
bguillaum's avatar
bguillaum committed
643
         }
bguillaum's avatar
bguillaum committed
644 645 646 647 648 649 650
        | l ->
          Error.build ~loc:(file_name,line_num) "[Conll.load] illegal line, %d fields (10 are expected)\n>>>>>%s<<<<<<" (List.length l) line
    with exc -> Error.build ~loc:(file_name,line_num) "[Conll.load] illegal line, exc=%s\n>>>>>%s<<<<<<" (Printexc.to_string exc) line

  let load file_name =
    let lines = File.read_ln file_name in
    List.map (parse_line file_name) lines
bguillaum's avatar
bguillaum committed
651

bguillaum's avatar
bguillaum committed
652
  let parse file_name lines = List.map (parse_line file_name) lines
bguillaum's avatar
bguillaum committed
653
end (* module Conll *)
654

bguillaum's avatar
bguillaum committed
655
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
656
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
657 658 659 660 661 662
module Lex_par = struct

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

  type t = item list

663 664 665
  let empty=[]
  let append = List.append

bguillaum's avatar
bguillaum committed
666
  let rm_peripheral_white s =
667 668 669
    Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
    (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)

bguillaum's avatar
bguillaum committed
670
  let parse_line ?loc nb_p nb_c line =
671
    let line = rm_peripheral_white line in
672 673 674 675 676 677 678 679 680 681 682 683 684
    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
685
            | _ -> Error.bug ?loc
686 687 688
              "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
689

690
  let from_lines ?loc nb_p nb_c lines = List_.opt_map (parse_line ?loc nb_p nb_c) lines
691

692
  let load ?loc dir nb_p nb_c file =
693
    try
bguillaum's avatar
bguillaum committed
694
      let full_file =
695 696 697 698
        if Filename.is_relative file
        then Filename.concat dir file
        else file in
      let lines = File.read full_file in
699
      List_.opt_mapi (fun i line -> parse_line ~loc:(full_file,i) nb_p nb_c line) lines
700 701
    with Sys_error _ -> Error.build ?loc "External lexical file '%s' not found" file

bguillaum's avatar
bguillaum committed
702 703 704
  let sub x y = List.mem x (Str.split (Str.regexp "|") y)

  let filter index atom t =
bguillaum's avatar
bguillaum committed
705
    match
bguillaum's avatar
bguillaum committed
706 707 708
      List_.opt_map
        (fun (p_par, c_par) ->
          let par = List.nth p_par index in
bguillaum's avatar
bguillaum committed
709
          if atom=par
bguillaum's avatar
bguillaum committed
710 711 712 713 714 715
          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
716
    with
717
    | [] -> None
bguillaum's avatar
bguillaum committed
718
    | t -> Some t
bguillaum's avatar
bguillaum committed
719 720 721 722 723

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

724 725 726
  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
727 728 729 730 731 732
    | (_,[sing])::tail when index=0 ->
        Printf.sprintf "%s/%s"
          sing
          (List_.to_string
             (function
               | (_,[s]) -> s
bguillaum's avatar
bguillaum committed
733 734 735
               | _ -> Error.bug "[Lex_par.get_command_value] inconsistent param"
             ) "/" tail
          )
736
    | l -> Error.run "Lexical parameter are not functionnal"
737

bguillaum's avatar
bguillaum committed
738
end (* module Lex_par *)
739

bguillaum's avatar
bguillaum committed
740
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
741 742 743
(* copy from leopar *)
module Timeout = struct
  exception Stop
744

bguillaum's avatar
bguillaum committed
745 746
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
747

bguillaum's avatar
bguillaum committed
748 749 750
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
751
    match !timeout with
bguillaum's avatar
bguillaum committed
752 753 754 755
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
756
end (* module Timeout *)