grew_grs.ml 19.8 KB
Newer Older
bguillaum's avatar
bguillaum committed
1 2 3
(**********************************************************************************)
(*    Libcaml-grew - a Graph Rewriting library dedicated to NLP applications      *)
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
4
(*    Copyright 2011-2018 Inria, Université de Lorraine                           *)
bguillaum's avatar
bguillaum committed
5
(*                                                                                *)
Bruno Guillaume's avatar
Bruno Guillaume committed
6
(*    Webpage: http://grew.fr                                                     *)
bguillaum's avatar
bguillaum committed
7 8 9 10
(*    License: CeCILL (see LICENSE folder or "http://www.cecill.info")            *)
(*    Authors: see AUTHORS file                                                   *)
(**********************************************************************************)

pj2m's avatar
pj2m committed
11 12 13
open Printf
open Log

14
open Grew_fs
15
open Grew_base
16
open Grew_types
bguillaum's avatar
bguillaum committed
17
open Grew_ast
18
open Grew_domain
19
open Grew_edge
bguillaum's avatar
bguillaum committed
20 21 22
open Grew_command
open Grew_graph
open Grew_rule
bguillaum's avatar
bguillaum committed
23
open Grew_loader
pj2m's avatar
pj2m committed
24

bguillaum's avatar
bguillaum committed
25
(* ================================================================================ *)
26
module Grs = struct
27 28 29

  type decl =
  | Rule of Rule.t
30
  | Strategy of string * Ast.strat
31 32 33 34 35 36
  | Package of string * decl list

  type t = {
    filename: string;
    domain: Domain.t option;
    decls: decl list;
37
    ast: Ast.grs;
38 39
  }

40 41
  let rec decl_to_json ?domain = function
    | Rule r -> Rule.to_json ?domain r
42
    | Strategy (name, strat) -> `Assoc [("strat_name", `String name); ("strat_def", Ast.strat_to_json strat)]
43
    | Package (name, decl_list) -> `Assoc [("package_name", `String name); "decls", `List (List.map (decl_to_json ?domain) decl_list)]
Bruno Guillaume's avatar
Bruno Guillaume committed
44 45 46 47 48 49 50 51 52 53

  let to_json t =
    match t.domain with
    | None -> `Assoc [
      "filename", `String t.filename;
      "decls", `List (List.map decl_to_json t.decls)
    ]
    | Some dom -> `Assoc [
      "domain", Domain.to_json dom;
      "filename", `String t.filename;
54
      "decls", `List (List.map (decl_to_json ~domain:dom) t.decls)
Bruno Guillaume's avatar
Bruno Guillaume committed
55 56 57
    ]


58
  let get_strat_list grs = Grew_ast.Ast.strat_list grs.ast
59

60 61 62 63 64 65 66 67
  let rec dump_decl indent = function
    | Rule r -> printf "%srule %s\n" (String.make indent ' ') (Rule.get_name r)
    | Strategy (name, def) -> printf "%sstrat %s\n" (String.make indent ' ') name
    | Package (name, decl_list) ->
      printf "%spackage %s:\n" (String.make indent ' ') name;
      List.iter (dump_decl (indent + 2)) decl_list

  let dump t =
68
    printf "================ Grs ================\n";
69 70 71
    Domain.dump t.domain;
    printf "-----------------------\n";
    List.iter (dump_decl 0) t.decls;
72
    printf "================ Grs ================\n%!";
73 74 75 76
    ()


  let rec build_decl ?domain = function
77 78 79
  | Ast.Package (loc, name, decl_list) -> Package (name, List.map (build_decl ?domain) decl_list)
  | Ast.Rule ast_rule -> Rule (Rule.build ?domain "TODO: remove this arg (old grs)" ast_rule)
  | Ast.Strategy (loc, name, ast_strat) -> Strategy (name, ast_strat)
80 81 82 83
  | _ -> Error.bug "[build_decl] Inconsistent ast for new_grs"

  let domain t = t.domain

Bruno Guillaume's avatar
Bruno Guillaume committed
84 85 86 87 88
  let domain_build ast_domain =
    Domain.build
      (Label_domain.build ast_domain.Ast.label_domain)
      (Feature_domain.build ast_domain.Ast.feature_domain)

89
  let from_ast filename ast =
90 91
    let feature_domains = List_.opt_map
      (fun x -> match x with
92
        | Ast.Features desc -> Some desc
93 94
        | _ -> None
      ) ast in
95

96 97
    let feature_domain = match feature_domains with
    | [] -> None
98
    | h::t -> Some (Feature_domain.build (List.fold_left Feature_domain.merge h t)) in
99 100 101

    let label_domains = List_.opt_map
      (fun x -> match x with
102
        | Ast.Labels desc -> Some desc
103 104 105 106
        | _ -> None
      ) ast in
    let label_domain = match label_domains with
    | [] -> None
107
    | h::t -> Some (Label_domain.build (List.fold_left Label_domain.merge h t)) in
108 109 110 111 112 113 114

    let domain = match (label_domain, feature_domain) with
    | (None, None) -> None
    | (Some ld, None) -> Some (Domain.build_labels_only ld)
    | (None, Some fd) -> Some (Domain.build_features_only fd)
    | (Some ld, Some fd) -> Some (Domain.build ld fd) in

115 116
    let decls = List_.opt_map
      (fun x -> match x with
117 118 119 120 121
        | Ast.Features _ -> None
        | Ast.Labels _ -> None
        | Ast.Conll_fields _ -> None
        | Ast.Import _ -> Error.bug "[load] Import: inconsistent ast for new_grs"
        | Ast.Include _ -> Error.bug "[load] Include: inconsistent ast for new_grs"
122 123 124
        | x -> Some (build_decl ?domain x)
      ) ast in

125 126
    { filename;
      ast;
127
      domain;
128
      decls;
129
    }
Bruno Guillaume's avatar
Bruno Guillaume committed
130

131 132
  let load filename = from_ast filename (Loader.new_grs filename)

Bruno Guillaume's avatar
Bruno Guillaume committed
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186
  (* The type [pointed] is a zipper style data structure for resolving names x.y.z *)
  type pointed =
  | Top of decl list
  | Pack of (decl list * pointed)  (* (content, mother package) *)





  let top grs = Top grs.decls

  let decl_list = function
  | Top dl -> dl
  | Pack (dl, _) -> dl

  let down pointed name =
    let rec loop = function
    | [] -> None
    | Package (n,dl) :: _ when n=name -> Some (Pack (dl, pointed))
    | _::t -> loop t in
    loop (decl_list pointed)


  (* search for a decl named [name] defined in the working directory [wd] in [grs] *)
  let rec search_at pointed path = match path with
    | [] -> None
    | [one] ->
      (
        try
          let item = List.find (* ?? rule and strategy with the same name ?? *)
            (function
              | Strategy (s,_) when s=one -> true
              | Rule r when Rule.get_name r = one -> true
              | Package (p,_) when p=one -> true
              | _ -> false
            ) (decl_list pointed) in
          Some (item, pointed)
        with Not_found -> None
      )
    | head::tail ->
      match down pointed head with
      | None -> None
      | Some new_p -> search_at new_p tail

  (* search for the path in current location and recursively on mother structure *)
  let rec search_from pointed path =
    match search_at pointed path with
      | Some r_or_s -> Some r_or_s
      | None ->
      (match pointed with
        | Top _ -> None
        | Pack (_,mother) -> search_from mother path
      )

Bruno Guillaume's avatar
Bruno Guillaume committed
187

188 189 190 191
  (* return true if strat always return at least one graph *)
  let at_least_one grs strat =
    let rec loop pointed strat =
      match strat with
192
      | Ast.Ref strat_name ->
193 194 195 196 197 198 199 200
        begin
          let path = Str.split (Str.regexp "\\.") strat_name in
          match search_from pointed path with
          | None -> Error.build "cannot find strat %s" strat_name
          | Some (Rule _,_)
          | Some (Package _, _) -> false
          | Some (Strategy (_,ast_strat), new_pointed) -> loop new_pointed ast_strat
        end
201 202 203 204 205 206 207
      | Ast.Pick s -> loop pointed s
      | Ast.Onf s -> true
      | Ast.Alt l -> List.exists (fun s -> loop pointed s) l
      | Ast.Seq l -> List.for_all (fun s -> loop pointed s) l
      | Ast.Iter _ -> true
      | Ast.If (_,s1, s2) -> (loop pointed s1) && (loop pointed s2)
      | Ast.Try (s) -> loop pointed s in
208 209 210 211 212 213
    loop (top grs) (Parser.strategy strat)

  (* return true if strat always return at most one graph *)
  let at_most_one grs strat =
    let rec loop pointed strat =
      match strat with
214
      | Ast.Ref strat_name ->
215 216 217 218 219 220 221 222
        begin
          let path = Str.split (Str.regexp "\\.") strat_name in
          match search_from pointed path with
          | None -> Error.build "cannot find strat %s" strat_name
          | Some (Rule _,_)
          | Some (Package _, _) -> false
          | Some (Strategy (_,ast_strat), new_pointed) -> loop new_pointed ast_strat
        end
223 224 225 226 227 228 229 230
      | Ast.Pick s -> true
      | Ast.Onf s -> true
      | Ast.Alt [one] -> loop pointed one
      | Ast.Alt _ -> false
      | Ast.Seq l -> List.for_all (fun s -> loop pointed s) l
      | Ast.Iter s -> loop pointed s
      | Ast.If (_,s1, s2) -> (loop pointed s1) || (loop pointed s2)
      | Ast.Try (s) -> loop pointed s in
231
    loop (top grs) (Parser.strategy strat)
232 233


234 235 236 237 238

  (* ============================================================================================= *)
  (* Rewriting in the deterministic case with graph type *)
  (* ============================================================================================= *)

239
  (* apply a package to an graph = apply only top level rules in the package *)
240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
  let onf_pack_rewrite ?domain decl_list graph =
    let rec loop = function
      | [] -> None
      | Rule r :: tail_decl ->
        (match Rule.onf_apply ?domain r graph with
        | Some x -> Some x
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

  let rec onf_intern_simple_rewrite ?domain pointed strat_name graph =
    let path = Str.split (Str.regexp "\\.") strat_name in
    match search_from pointed path with
    | None -> Error.build "Simple rewrite, cannot find strat %s" strat_name
    | Some (Rule r,_) -> Rule.onf_apply ?domain r graph
    | Some (Package (_, decl_list), _) -> onf_pack_rewrite ?domain decl_list graph
    | Some (Strategy (_,ast_strat), new_pointed) ->
      onf_strat_simple_rewrite ?domain new_pointed ast_strat graph

  and onf_strat_simple_rewrite ?domain pointed strat graph =
    match strat with
262 263
    | Ast.Ref subname -> onf_intern_simple_rewrite ?domain pointed subname graph
    | Ast.Pick strat -> onf_strat_simple_rewrite ?domain pointed strat graph
264

265 266
    | Ast.Alt [] -> None
    | Ast.Alt strat_list ->
267 268 269 270 271 272 273 274
      let rec loop = function
        | [] -> None
        | head_strat :: tail_strat ->
          match onf_strat_simple_rewrite ?domain pointed head_strat graph with
          | None -> loop tail_strat
          | Some x -> Some x in
        loop strat_list

275 276
    | Ast.Seq [] -> Some graph
    | Ast.Seq (head_strat :: tail_strat) ->
277 278 279
      begin
        match onf_strat_simple_rewrite ?domain pointed head_strat graph with
        | None -> None
280
        | Some inst -> onf_strat_simple_rewrite ?domain pointed (Ast.Seq tail_strat) inst
281 282
      end

283
    | Ast.Iter sub_strat ->
284 285 286 287 288 289
      begin
        match onf_strat_simple_rewrite ?domain pointed sub_strat graph with
        | None -> Some graph
        | Some inst -> onf_strat_simple_rewrite ?domain pointed strat inst
        end

290
    | Ast.Try sub_strat ->
291 292 293 294 295 296
        begin
          match onf_strat_simple_rewrite ?domain pointed sub_strat graph with
          | None -> Some graph
          | Some i -> Some i
        end

297
    | Ast.If (s, s1, s2) ->
298 299 300 301 302 303
      begin
        match onf_strat_simple_rewrite ?domain pointed s graph with
        | None   -> onf_strat_simple_rewrite ?domain pointed s1 graph
        | Some _ -> onf_strat_simple_rewrite ?domain pointed s2 graph
      end

304
    | Ast.Onf (s) -> onf_strat_simple_rewrite ?domain pointed s graph (* TODO check Onf (P) == 1 rule app ? *)
305

306 307 308
  (* ============================================================================================= *)
  (* Rewriting in the non-deterministic case with Graph_with_history.t type *)
  (* ============================================================================================= *)
309

310
  (* apply a package to an graph_with_history = apply only top level rules in the package *)
311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328
  let gwh_pack_rewrite ?domain decl_list gwh =
    List.fold_left
      (fun acc decl -> match decl with
        | Rule r -> Graph_with_history_set.union acc (Rule.gwh_apply ?domain r gwh)
        | _ -> acc
      ) Graph_with_history_set.empty decl_list

  let rec gwh_intern_simple_rewrite ?domain pointed strat_name gwh =
    let path = Str.split (Str.regexp "\\.") strat_name in
    match search_from pointed path with
    | None -> Error.build "Simple rewrite, cannot find strat %s" strat_name
    | Some (Rule r,_) -> Rule.gwh_apply r gwh
    | Some (Package (_, decl_list), _) -> gwh_pack_rewrite decl_list gwh
    | Some (Strategy (_,ast_strat), new_pointed) ->
      gwh_strat_simple_rewrite ?domain new_pointed ast_strat gwh

  and gwh_strat_simple_rewrite ?domain pointed strat gwh =
    match strat with
329 330
    | Ast.Ref subname -> gwh_intern_simple_rewrite ?domain pointed subname gwh
    | Ast.Pick strat ->
331 332 333 334 335 336 337
      begin
        match Graph_with_history_set.choose_opt
          (gwh_strat_simple_rewrite ?domain pointed strat gwh) with
        | None -> Graph_with_history_set.empty
        | Some x -> Graph_with_history_set.singleton x
      end

338 339
    | Ast.Alt [] -> Graph_with_history_set.empty
    | Ast.Alt strat_list -> List.fold_left
340 341 342
      (fun acc strat -> Graph_with_history_set.union acc (gwh_strat_simple_rewrite ?domain pointed strat gwh)
      ) Graph_with_history_set.empty strat_list

343 344
    | Ast.Seq [] -> Graph_with_history_set.singleton gwh
    | Ast.Seq (head_strat :: tail_strat) ->
345 346
      let first_strat = gwh_strat_simple_rewrite ?domain pointed head_strat gwh in
      Graph_with_history_set.fold
347
        (fun gwh acc -> Graph_with_history_set.union acc (gwh_strat_simple_rewrite ?domain pointed (Ast.Seq tail_strat) gwh)
348 349
        ) first_strat Graph_with_history_set.empty

350
    | Ast.Iter strat -> iter_gwh ?domain pointed strat gwh
351

352
    | Ast.Try strat ->
353 354 355 356 357 358 359
      begin
        let one_step = gwh_strat_simple_rewrite ?domain pointed strat gwh in
        if Graph_with_history_set.is_empty one_step
        then Graph_with_history_set.singleton gwh
        else one_step
      end

360
    | Ast.If (s, s1, s2) ->
361 362 363
      begin
        match (* TODO: is it correct to put onf_ ?*)
        onf_strat_simple_rewrite ?domain pointed s gwh.Graph_with_history.graph with
364 365
        | Some _ -> gwh_strat_simple_rewrite ?domain pointed s1 gwh
        | None   -> gwh_strat_simple_rewrite ?domain pointed s2 gwh
366 367
      end

368
    | Ast.Onf s ->
369
      begin
370
        match onf_strat_simple_rewrite ?domain pointed (Ast.Iter s) gwh.Graph_with_history.graph with
Bruno Guillaume's avatar
Bruno Guillaume committed
371
        | None -> Graph_with_history_set.singleton gwh
372 373 374 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 400 401 402
        | Some new_g -> Graph_with_history_set.singleton (Graph_with_history.from_graph new_g)
      end

  and iter_gwh ?domain pointed strat gwh =
    let rec loop  (todo, not_nf, nf) =
      match Graph_with_history_set.choose_opt todo with
      | None -> nf
      | Some one ->
        let new_todo = Graph_with_history_set.remove one todo in
        let one_step = gwh_strat_simple_rewrite ?domain pointed strat one in
        if Graph_with_history_set.subset one_step (Graph_with_history_set.singleton one)
        then
        loop (
          new_todo,
          not_nf,
          Graph_with_history_set.add one nf
        )
        else
          let new_graphs =
            (Graph_with_history_set.diff
              (Graph_with_history_set.diff
                (Graph_with_history_set.diff one_step todo)
              not_nf)
            nf) in
        loop (
          Graph_with_history_set.union new_todo new_graphs,
          Graph_with_history_set.add one not_nf,
          nf
        ) in
      loop (Graph_with_history_set.singleton gwh, Graph_with_history_set.empty, Graph_with_history_set.empty)

403 404

  let gwh_simple_rewrite grs strat_string graph =
405
    let domain = domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
406
    let casted_graph = G_graph.cast ?domain graph in
407
    let strat = Parser.strategy strat_string in
Bruno Guillaume's avatar
Bruno Guillaume committed
408
    let gwh = Graph_with_history.from_graph casted_graph in
409
    let set = gwh_strat_simple_rewrite ?domain (top grs) strat gwh in
410 411 412 413 414
    List.map
      (fun gwh -> gwh.Graph_with_history.graph)
      (Graph_with_history_set.elements set)


415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471
  (* ============================================================================================= *)
  (* production of rew_display of linear rewriting history for GUI *)
  (* ============================================================================================= *)
  type linear_rd = {
    graph: G_graph.t;
    steps: (string * G_graph.t * Libgrew_types.big_step) list;
  }

  let wrd_pack_rewrite ?domain decl_list graph_with_big_step =
    let rec loop = function
      | [] -> None
      | Rule r :: tail_decl ->
        (match Rule.wrd_apply ?domain r graph_with_big_step with
        | Some x -> Some x
        | None -> loop tail_decl
        )
      | _ :: tail_decl -> loop tail_decl in
      loop decl_list

  let rec wrd_pack_iter_rewrite ?domain decl_list graph_with_big_step =
    match (graph_with_big_step, wrd_pack_rewrite ?domain decl_list graph_with_big_step) with
      | (_, Some (new_gr, new_bs)) -> wrd_pack_iter_rewrite ?domain decl_list (new_gr, Some new_bs)
      | ((gr, Some bs), None) -> Some (gr, bs)
      | ((gr, None), None) -> None

  (* functions [wrd_intern_simple_rewrite] and [wrd_strat_simple_rewrite] computes
     one normal form and output the data needed for rew_display production.
     output = list of ... tranformed later into rew_display by [build_rew_display_from_linear_rd]
     [iter_flag] is set to true when rules application should be put together (in the old modules style).
  *)
  let rec wrd_intern_simple_rewrite ?domain iter_flag pointed strat_name linear_rd =
    let path = Str.split (Str.regexp "\\.") strat_name in
    match search_from pointed path with
    | None -> Error.build "Simple rewrite, cannot find strat %s" strat_name
    | Some (Rule r,_) ->
      begin
        match Rule.wrd_apply ?domain r (linear_rd.graph, None) with
          | None -> None
          | Some (new_graph, big_step) -> Some {steps = (Rule.get_name r, linear_rd.graph, big_step) :: linear_rd.steps; graph = new_graph}
      end
    | Some (Package (name, decl_list), _) when iter_flag ->
      begin
        match wrd_pack_iter_rewrite ?domain decl_list (linear_rd.graph, None) with
          | None -> None
          | Some (new_graph, big_step) -> Some {steps = (name, linear_rd.graph, big_step) :: linear_rd.steps; graph = new_graph}
      end
    | Some (Package (name, decl_list), _) ->
      begin
        match wrd_pack_rewrite ?domain decl_list (linear_rd.graph, None) with
          | None -> None
          | Some (new_graph, big_step) -> Some {steps = (name, linear_rd.graph, big_step) :: linear_rd.steps; graph = new_graph}
      end
    | Some (Strategy (_,ast_strat), new_pointed) ->
      wrd_strat_simple_rewrite ?domain iter_flag new_pointed ast_strat linear_rd

  and wrd_strat_simple_rewrite ?domain iter_flag pointed strat linear_rd  =
    match strat with
472 473
    | Ast.Ref subname -> wrd_intern_simple_rewrite iter_flag ?domain pointed subname linear_rd
    | Ast.Pick strat -> wrd_strat_simple_rewrite iter_flag ?domain pointed strat linear_rd
474

475 476
    | Ast.Alt [] -> None
    | Ast.Alt strat_list ->
477 478 479 480 481 482 483 484
      let rec loop = function
        | [] -> None
        | head_strat :: tail_strat ->
          match wrd_strat_simple_rewrite ?domain false pointed head_strat linear_rd  with
          | None -> loop tail_strat
          | Some x -> Some x in
        loop strat_list

485 486
    | Ast.Seq [] -> Some linear_rd
    | Ast.Seq (head_strat :: tail_strat) ->
487 488 489
      begin
        match wrd_strat_simple_rewrite ?domain false pointed head_strat linear_rd  with
        | None -> None
490
        | Some gwrd -> wrd_strat_simple_rewrite iter_flag ?domain pointed (Ast.Seq tail_strat) gwrd
491 492
      end

493 494
    | Ast.Iter sub_strat
    | Ast.Onf sub_strat ->
495 496 497 498 499 500
      begin
        match wrd_strat_simple_rewrite ?domain true pointed sub_strat linear_rd  with
        | None -> Some linear_rd
        | Some gwrd -> wrd_strat_simple_rewrite ?domain iter_flag pointed strat gwrd
      end

501
    | Ast.Try sub_strat ->
502 503 504 505 506 507
        begin
          match wrd_strat_simple_rewrite ?domain false pointed sub_strat linear_rd  with
          | None -> Some linear_rd
          | Some i -> Some i
        end

508
    | Ast.If (s, s1, s2) ->
509 510
      begin
        match onf_strat_simple_rewrite ?domain pointed s linear_rd.graph with
511 512
        | Some _ -> wrd_strat_simple_rewrite iter_flag ?domain pointed s1 linear_rd
        | None   -> wrd_strat_simple_rewrite iter_flag ?domain pointed s2 linear_rd
513 514 515 516 517 518 519 520
      end

  let build_rew_display_from_linear_rd linear_rd =
    List.fold_left
      (fun acc (n,g,bs) -> Libgrew_types.Node (g, n, [Libgrew_types.swap bs, acc])) (Libgrew_types.Leaf linear_rd.graph) linear_rd.steps

  let wrd_rewrite grs strat graph =
    let domain = domain grs in
Bruno Guillaume's avatar
Bruno Guillaume committed
521
    let casted_graph = G_graph.cast ?domain graph in
522 523 524 525
    match wrd_strat_simple_rewrite ?domain false (top grs) (Parser.strategy strat) {graph=casted_graph; steps=[]} with
    | None -> Libgrew_types.Leaf graph
    | Some linear_rd -> build_rew_display_from_linear_rd linear_rd

526
end (* module Grs *)
527 528 529 530 531 532 533 534