grew_utils.ml 21.9 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

bguillaum's avatar
bguillaum committed
11 12 13 14 15 16
(* ================================================================================ *)
module String_ = struct

  let to_float string =
    try float_of_string string
    with _ -> float_of_string (Str.global_replace (Str.regexp "\\.") "," string)
17

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

bguillaum's avatar
bguillaum committed
20
end (* module String_ *)
21

bguillaum's avatar
bguillaum committed
22 23 24 25 26 27 28 29
(* ================================================================================ *)
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 *)
30

bguillaum's avatar
bguillaum committed
31 32
(* ================================================================================ *)
module Loc = struct
bguillaum's avatar
bguillaum committed
33
  type t = string * int
bguillaum's avatar
bguillaum committed
34

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

bguillaum's avatar
bguillaum committed
37 38 39 40
  let opt_set_line line = function
    | None -> None
    | Some (file,_) -> Some (file, line)

bguillaum's avatar
bguillaum committed
41 42 43 44 45 46 47 48 49 50 51 52
  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
53
  let read file =
bguillaum's avatar
bguillaum committed
54 55 56 57 58 59 60 61 62
    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
63
    with End_of_file ->
bguillaum's avatar
bguillaum committed
64 65
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
66

bguillaum's avatar
bguillaum committed
67 68
  (* [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
69 70 71 72 73 74 75 76 77 78 79
    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
80
    with End_of_file ->
bguillaum's avatar
bguillaum committed
81 82
      close_in in_ch;
      List.rev !rev_lines
bguillaum's avatar
bguillaum committed
83 84 85
 end (* module File *)

(* ================================================================================ *)
86
module Pid = struct
bguillaum's avatar
bguillaum committed
87 88 89
  (* type t = int *)
  type t = Pos of int | Neg of int

90
  let compare = Pervasives.compare
bguillaum's avatar
bguillaum committed
91 92 93 94 95 96 97 98

  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
99 100 101
end (* module Pid *)

(* ================================================================================ *)
102
module Pid_map =
bguillaum's avatar
bguillaum committed
103
  struct
104
    include Map.Make (Pid)
105

pj2m's avatar
pj2m committed
106
    exception True
bguillaum's avatar
bguillaum committed
107

pj2m's avatar
pj2m committed
108 109
    let exists fct map =
      try
bguillaum's avatar
bguillaum committed
110 111 112
        iter
          (fun key value ->
            if fct key value
113 114 115
            then raise True
          ) map;
        false
pj2m's avatar
pj2m committed
116 117
      with True -> true

bguillaum's avatar
bguillaum committed
118 119
    (* let range key_set m =  *)
    (*   IntSet.fold (fun k s -> (IntSet.add (find k m) s)) key_set IntSet.empty *)
120

bguillaum's avatar
bguillaum committed
121 122
    (* let keys m =  *)
    (*   fold (fun k v s -> (IntSet.add k s)) m IntSet.empty *)
123

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

bguillaum's avatar
bguillaum committed
127
  end (* module Pid_map *)
pj2m's avatar
pj2m committed
128

bguillaum's avatar
bguillaum committed
129 130 131
(* ================================================================================ *)
module Pid_set = Set.Make (Pid)

bguillaum's avatar
bguillaum committed
132 133
(* ================================================================================ *)
module Gid = struct
134 135
  type t =
    | Old of int
136
    | New of (int * int) (* identifier for "created nodes" *)
137

bguillaum's avatar
bguillaum committed
138
  (* a compare function which ensures that new nodes are at the "end" of the graph *)
139 140 141 142 143
  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
144 145 146 147

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

bguillaum's avatar
bguillaum committed
150
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
151
module Gid_map = Map.Make (Gid)
pj2m's avatar
pj2m committed
152

bguillaum's avatar
bguillaum committed
153
(* ================================================================================ *)
pj2m's avatar
pj2m committed
154 155 156
module Array_ = struct
  let dicho_mem elt array =
    let rec loop low high =
bguillaum's avatar
bguillaum committed
157
      (if low > high
pj2m's avatar
pj2m committed
158 159
      then false
      else
160 161 162 163
        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
164
      ) in
pj2m's avatar
pj2m committed
165 166 167 168 169 170 171 172 173
    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
174
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
175
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
176

pj2m's avatar
pj2m committed
177 178 179 180 181 182
  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
183
      | middle -> loop low (middle - 1) in
pj2m's avatar
pj2m committed
184
    loop 0 ((Array.length array) - 1)
bguillaum's avatar
bguillaum committed
185
end (* module Array_ *)
pj2m's avatar
pj2m committed
186

bguillaum's avatar
bguillaum committed
187
(* ================================================================================ *)
pj2m's avatar
pj2m committed
188
module List_ = struct
bguillaum's avatar
bguillaum committed
189 190 191 192 193
  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
194 195 196 197 198
  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
199
  let pos x l =
bguillaum's avatar
bguillaum committed
200 201 202 203 204 205
    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
206 207 208 209 210 211 212
  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
213
    | x::t ->
214 215 216
        match f x with
        | None -> opt_map f t
        | Some r -> r :: (opt_map f t)
pj2m's avatar
pj2m committed
217 218 219 220 221

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

bguillaum's avatar
bguillaum committed
222 223
  let iteri fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
224 225 226
      | [] -> ()
      | h::t -> (fct i h); (loop (i+1) t) in
    loop 0
bguillaum's avatar
bguillaum committed
227 228 229

  let mapi fct =
    let rec loop i = function
pj2m's avatar
pj2m committed
230 231 232 233
      | [] -> []
      | h::t -> let head = fct i h in head :: (loop (i+1) t)
    in loop 0

bguillaum's avatar
bguillaum committed
234 235
  let opt_mapi fct =
    let rec loop i = function
236 237 238 239 240 241 242
      | [] -> []
      | 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
243
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
244 245
    fst
      (List.fold_left
246 247
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
pj2m's avatar
pj2m committed
248 249 250 251 252 253
      )

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

pj2m's avatar
pj2m committed
255 256 257
  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
258

pj2m's avatar
pj2m committed
259 260
  let rec sort_insert elt = function
    | [] -> [elt]
bguillaum's avatar
bguillaum committed
261
    | h::t when elt<h -> elt::h::t
pj2m's avatar
pj2m committed
262 263 264 265 266 267
    | h::t -> h::(sort_insert elt t)

  let rec sort_mem elt = function
    | [] -> false
    | h::_ when elt<h -> false
    | h::_ when elt=h -> true
268
    | h::t (* when elt>h *) -> sort_mem elt t
269 270 271 272 273

  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
274
    | (_,v)::_ -> Some v
275 276 277 278 279 280 281

  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
282 283
  exception Usort

bguillaum's avatar
bguillaum committed
284
  let rec usort_remove key = function
pj2m's avatar
pj2m committed
285 286 287 288 289 290 291 292 293 294 295 296
    | [] -> 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
297

bguillaum's avatar
bguillaum committed
298
  let rec sort_disjoint l1 l2 =
pj2m's avatar
pj2m committed
299 300 301 302
    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
303
    | _ -> false
304

bguillaum's avatar
bguillaum committed
305
  let sort_is_empty_inter l1 l2 =
pj2m's avatar
pj2m committed
306 307 308 309 310
    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
311
    loop (l1,l2)
pj2m's avatar
pj2m committed
312

bguillaum's avatar
bguillaum committed
313
  let sort_inter l1 l2 =
pj2m's avatar
pj2m committed
314 315 316 317 318 319
    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
320 321

  let sort_union l1 l2 =
bguillaum's avatar
bguillaum committed
322 323 324 325 326 327 328 329
    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
330
  exception Not_disjoint
bguillaum's avatar
bguillaum committed
331
  let sort_disjoint_union ?(compare=Pervasives.compare) l1 l2 =
pj2m's avatar
pj2m committed
332 333 334 335 336 337
    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
338 339

  let sort_include l1 l2 =
pj2m's avatar
pj2m committed
340 341 342 343 344 345 346
    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
347 348

  let sort_included_diff l1 l2 =
pj2m's avatar
pj2m committed
349 350 351 352 353 354 355 356
    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
357
  let sort_diff l1 l2 =
pj2m's avatar
pj2m committed
358 359 360 361 362 363 364 365
    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)

366
  let foldi_left f init l =
bguillaum's avatar
bguillaum committed
367 368
    fst
      (List.fold_left
369 370
         (fun (acc,i) elt -> (f i acc elt, i+1))
         (init,0) l
371
      )
bguillaum's avatar
bguillaum committed
372
end (* module List_ *)
pj2m's avatar
pj2m committed
373

bguillaum's avatar
bguillaum committed
374
(* ================================================================================ *)
375 376 377 378
module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
bguillaum's avatar
bguillaum committed
379
  end (* module type OrderedType *)
380

bguillaum's avatar
bguillaum committed
381
(* ================================================================================ *)
382 383 384 385 386 387 388 389
module type S =
  sig
    type key

    type +'a t

    val empty: 'a t

bguillaum's avatar
bguillaum committed
390
    (* an empty list returned if the key is undefined *)
391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415
    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
416
    val disjoint_union: 'a t -> 'a t -> 'a t
417 418 419 420 421

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

    val exists: (key -> 'a -> bool) -> 'a t -> bool
422 423

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

bguillaum's avatar
bguillaum committed
426
(* ================================================================================ *)
427 428 429 430 431 432 433 434 435 436 437
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
438 439
  let assoc key t =
    try M.find key t
440 441
    with Not_found -> []

bguillaum's avatar
bguillaum committed
442
  let to_string _ _ = failwith "Not implemted"
443 444

  let iter fct t =
bguillaum's avatar
bguillaum committed
445
    M.iter
446 447 448
      (fun key list -> List.iter (fun elt -> fct key elt) list
      ) t

bguillaum's avatar
bguillaum committed
449
  let add key elt t =
450 451
    try
      let list = M.find key t in
bguillaum's avatar
bguillaum committed
452
      match List_.usort_insert elt list with
453 454 455 456 457 458 459
        | 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
460
        List.fold_left
461 462 463 464
          (fun acc2 elt ->
            fct acc2 key elt)
          acc list)
      t init
bguillaum's avatar
bguillaum committed
465

466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482
  (* 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
483
    M.fold
484
      (fun key list acc ->
bguillaum's avatar
bguillaum committed
485
        try
486 487 488 489 490 491 492 493
          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
494

495 496 497 498 499
  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
500
    with
501 502 503
      | Not_found -> (* no key i *) t
      | List_.Not_disjoint -> raise Duplicate

bguillaum's avatar
bguillaum committed
504 505
(* New implementation of exists but exists fct not implemented in ocaml < 3.12 *)
(*
506 507 508 509 510
  let exists fct t =
    M.exists
      (fun key list ->
        List.exists (fun elt -> fct key elt) list
      ) t
bguillaum's avatar
bguillaum committed
511 512 513 514 515 516 517 518 519 520 521 522 523
*)

  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

524 525 526 527 528 529 530
  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

531 532
end (* module Massoc_make *)

bguillaum's avatar
bguillaum committed
533
(* ================================================================================ *)
534
module Massoc_gid = Massoc_make (Gid)
pj2m's avatar
pj2m committed
535

bguillaum's avatar
bguillaum committed
536 537 538
(* ================================================================================ *)
module Massoc_pid = Massoc_make (Pid)

bguillaum's avatar
bguillaum committed
539
(* ================================================================================ *)
pj2m's avatar
pj2m committed
540
module Error = struct
bguillaum's avatar
bguillaum committed
541 542 543 544 545

  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
546
  let build_ ?loc message =
pj2m's avatar
pj2m committed
547 548 549 550 551 552 553
    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
554 555
  let bug_ ?loc message = raise (Bug (message, loc))
  let bug ?loc = Printf.ksprintf (bug_ ?loc)
bguillaum's avatar
bguillaum committed
556
end (* module Error *)
pj2m's avatar
pj2m committed
557

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

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

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

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

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

bguillaum's avatar
bguillaum committed
613
  let load file =
bguillaum's avatar
bguillaum committed
614 615
    let parse_morph line_num = function
      | "_" -> []
bguillaum's avatar
bguillaum committed
616 617 618
      | morph ->
          List.map
            (fun feat ->
bguillaum's avatar
bguillaum committed
619 620 621
              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
622
              | _ -> Error.build ~loc:(file,line_num) "[Conll.load] illegal morphology \n>>>>>%s<<<<<<" morph
bguillaum's avatar
bguillaum committed
623
            ) (Str.split (Str.regexp "|") morph) in
bguillaum's avatar
bguillaum committed
624

bguillaum's avatar
bguillaum committed
625
    let escape_quote s = Str.global_replace (Str.regexp "\"") "\\\"" s in
bguillaum's avatar
bguillaum committed
626 627

    let parse (line_num, line) =
bguillaum's avatar
bguillaum committed
628
      match Str.split (Str.regexp "\t") line with
629
      | [ num; phon; lemma; pos1; pos2; morph; govs; dep_labs; _; _ ] ->
bguillaum's avatar
bguillaum committed
630
        let gov_list = Str.split (Str.regexp "|") govs
631 632
        and lab_list = Str.split (Str.regexp "|") dep_labs in
        let deps = List.combine gov_list lab_list in
bguillaum's avatar
bguillaum committed
633
          {line_num = line_num;
bguillaum's avatar
bguillaum committed
634
           num = num;
bguillaum's avatar
bguillaum committed
635 636
           phon = phon;
           lemma = lemma;
bguillaum's avatar
bguillaum committed
637 638 639
           pos1 = pos1;
           pos2 = pos2;
           morph = parse_morph line_num morph;
640
           deps = deps;
bguillaum's avatar
bguillaum committed
641
         }
bguillaum's avatar
bguillaum committed
642
      | l ->
643
          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
644 645 646

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

bguillaum's avatar
bguillaum committed
649
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
650
(* This module defines a type for lexical parameter (i.e. one line in a lexical file) *)
651 652 653 654 655 656
module Lex_par = struct

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

  type t = item list

657 658 659
  let empty=[]
  let append = List.append

bguillaum's avatar
bguillaum committed
660
  let rm_peripheral_white s =
661 662 663
    Str.global_replace (Str.regexp "\\( \\|\t\\)*$") ""
    (Str.global_replace (Str.regexp "^\\( \\|\t\\)*") "" s)

bguillaum's avatar
bguillaum committed
664
  let parse_line ?loc nb_p nb_c line =
665
    let line = rm_peripheral_white line in
666 667 668 669 670 671 672 673 674 675 676 677 678
    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
679
            | _ -> Error.bug ?loc
680 681 682
              "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
683

684
  let from_lines ?loc nb_p nb_c lines = List_.opt_map (parse_line ?loc nb_p nb_c) lines
685

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

bguillaum's avatar
bguillaum committed
696 697 698
  let sub x y = List.mem x (Str.split (Str.regexp "|") y)

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

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

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

bguillaum's avatar
bguillaum committed
732
end (* module Lex_par *)
733

bguillaum's avatar
bguillaum committed
734
(* ================================================================================ *)
bguillaum's avatar
bguillaum committed
735 736 737
(* copy from leopar *)
module Timeout = struct
  exception Stop
738

bguillaum's avatar
bguillaum committed
739 740
  let counter = ref 0.
  let timeout = ref None
bguillaum's avatar
bguillaum committed
741

bguillaum's avatar
bguillaum committed
742 743 744
  let start () = counter := Unix.time ()

  let check () =
bguillaum's avatar
bguillaum committed
745
    match !timeout with
bguillaum's avatar
bguillaum committed
746 747 748 749
    | None -> ()
    | Some delay ->
        if Unix.time () -. !counter > delay
        then raise Stop
bguillaum's avatar
bguillaum committed
750
end (* module Timeout *)