Source file automata.ml

(*
   RE - A regular expression library

   Copyright (C) 2001 Jerome Vouillon
   email: Jerome.Vouillon@pps.jussieu.fr

   This library is free software; you can redistribute it and/or
   modify it under the terms of the GNU Lesser General Public
   License as published by the Free Software Foundation, with
   linking exception; either version 2.1 of the License, or (at
   your option) any later version.

   This library is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   Lesser General Public License for more details.

   You should have received a copy of the GNU Lesser General Public
   License along with this library; if not, write to the Free Software
   Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*)

type sem = [ `Longest | `Shortest | `First ]

type rep_kind = [ `Greedy | `Non_greedy ]

type mark = int
type idx = int

type expr = { id : int; def : def }

and def =
    Cst of Cset.t
  | Alt of expr list
  | Seq of sem * expr * expr
  | Eps
  | Rep of rep_kind * sem * expr
  | Mark of int
  | Erase of int * int
  | Before of Category.t
  | After of Category.t
  | Pmark of Pmark.t

let hash_combine h accu = accu * 65599 + h

module Marks = struct
  type t =
    { marks : (int * int) list
    ; pmarks : Pmark.Set.t }

  let empty = { marks = [] ; pmarks = Pmark.Set.empty }

  let rec merge_marks_offset old = function
    | [] ->
      old
    | (i, v) :: rem ->
      let nw' = merge_marks_offset (List.remove_assq i old) rem in
      if v = -2 then
        nw'
      else
        (i, v) :: nw'

  let merge old nw =
    { marks = merge_marks_offset old.marks nw.marks
    ; pmarks = Pmark.Set.union old.pmarks nw.pmarks }

  let rec hash_marks_offset l accu =
    match l with
      []          -> accu
    | (a, i) :: r -> hash_marks_offset r (hash_combine a (hash_combine i accu))

  let hash m accu =
    hash_marks_offset m.marks (hash_combine (Hashtbl.hash m.pmarks) accu)

  let rec marks_set_idx idx = function
    | (a, -1) :: rem ->
      (a, idx) :: marks_set_idx idx rem
    | marks ->
      marks

  let marks_set_idx marks idx =
    { marks with marks = marks_set_idx idx marks.marks }

  let pp_marks ch t =
    match t.marks with
    | [] ->
      ()
    | (a, i) :: r ->
      Format.fprintf ch "%d-%d" a i;
      List.iter (fun (a, i) -> Format.fprintf ch " %d-%d" a i) r
end

(****)

let pp_sem ch k =
  Format.pp_print_string ch
    (match k with
       `Shortest -> "short"
     | `Longest  -> "long"
     | `First    -> "first")


let pp_rep_kind fmt = function
  | `Greedy -> Format.pp_print_string fmt "Greedy"
  | `Non_greedy -> Format.pp_print_string fmt "Non_greedy"

let rec pp ch e =
  let open Fmt in
  match e.def with
    Cst l ->
    sexp ch "cst" Cset.pp l;
  | Alt l ->
    sexp ch "alt" (list pp) l
  | Seq (k, e, e') ->
    sexp ch "seq" (triple pp_sem pp pp) (k, e, e')
  | Eps ->
    str ch "eps"
  | Rep (_rk, k, e) ->
    sexp ch "rep" (pair pp_sem pp) (k, e)
  | Mark i ->
    sexp ch "mark" int i
  | Pmark i ->
    sexp ch "pmark" int (i :> int)
  | Erase (b, e) ->
    sexp ch "erase" (pair int int) (b, e)
  | Before c ->
    sexp ch "before" Category.pp c
  | After c ->
    sexp ch "after" Category.pp c


(****)

let rec first f = function
  | [] ->
    None
  | x :: r ->
    match f x with
      None          -> first f r
    | Some _ as res -> res

(****)

type ids = int ref
let create_ids () = ref 0

let eps_expr = { id = 0; def = Eps }

let mk_expr ids def =
  incr ids;
  { id = !ids; def = def }

let empty ids = mk_expr ids (Alt [])

let cst ids s =
  if Cset.is_empty s
  then empty ids
  else mk_expr ids (Cst s)

let alt ids = function
  | []  -> empty ids
  | [c] -> c
  | l   -> mk_expr ids (Alt l)

let seq ids kind x y =
  match x.def, y.def with
    Alt [], _                 -> x
  | _, Alt []                 -> y
  | Eps, _                    -> y
  | _, Eps when kind = `First -> x
  | _                         -> mk_expr ids (Seq (kind, x, y))

let is_eps expr =
  match expr.def with
  | Eps -> true
  | _ -> false

let eps ids = mk_expr ids Eps

let rep ids kind sem x = mk_expr ids (Rep (kind, sem, x))

let mark ids m = mk_expr ids (Mark m)

let pmark ids i = mk_expr ids (Pmark i)

let erase ids m m' = mk_expr ids (Erase (m, m'))

let before ids c = mk_expr ids (Before c)

let after ids c = mk_expr ids (After c)

(****)

let rec rename ids x =
  match x.def with
    Cst _ | Eps | Mark _ | Pmark _ | Erase _ | Before _ | After _ ->
    mk_expr ids x.def
  | Alt l ->
    mk_expr ids (Alt (List.map (rename ids) l))
  | Seq (k, y, z) ->
    mk_expr ids (Seq (k, rename ids y, rename ids z))
  | Rep (g, k, y) ->
    mk_expr ids (Rep (g, k, rename ids y))

(****)

type hash = int
type mark_infos = int array
type status = Failed | Match of mark_infos * Pmark.Set.t | Running

module E = struct
  type t =
    | TSeq of t list * expr * sem
    | TExp of Marks.t * expr
    | TMatch of Marks.t

  let rec equal l1 l2 =
    match l1, l2 with
    | [], [] ->
      true
    | TSeq (l1', e1, _) :: r1, TSeq (l2', e2, _) :: r2 ->
      e1.id = e2.id && equal l1' l2' && equal r1 r2
    | TExp (marks1, e1) :: r1, TExp (marks2, e2) :: r2 ->
      e1.id = e2.id && marks1 = marks2 && equal r1 r2
    | TMatch marks1 :: r1, TMatch marks2 :: r2 ->
      marks1 = marks2 && equal r1 r2
    | _ ->
      false

  let rec hash l accu =
    match l with
    | [] ->
      accu
    | TSeq (l', e, _) :: r ->
      hash r (hash_combine 0x172a1bce (hash_combine e.id (hash l' accu)))
    | TExp (marks, e) :: r ->
      hash r
        (hash_combine 0x2b4c0d77 (hash_combine e.id (Marks.hash marks accu)))
    | TMatch marks :: r ->
      hash r (hash_combine 0x1c205ad5 (Marks.hash marks accu))

  let texp marks x = TExp (marks, x)

  let tseq kind x y rem =
    match x with
      []                              -> rem
    | [TExp (marks, {def = Eps ; _})] -> TExp (marks, y) :: rem
    | _                               -> TSeq (x, y, kind) :: rem

  let rec print_state_rec ch e y =
    match e with
    | TMatch marks ->
      Format.fprintf ch "@[<2>(Match@ %a)@]" Marks.pp_marks marks
    | TSeq (l', x, _kind) ->
      Format.fprintf ch "@[<2>(Seq@ ";
      print_state_lst ch l' x;
      Format.fprintf ch "@ %a)@]" pp x
    | TExp (marks, {def = Eps; _}) ->
      Format.fprintf ch "@[<2>(Exp@ %d@ (%a)@ (eps))@]" y.id Marks.pp_marks marks
    | TExp (marks, x) ->
      Format.fprintf ch "@[<2>(Exp@ %d@ (%a)@ %a)@]" x.id Marks.pp_marks marks pp x

  and print_state_lst ch l y =
    match l with
      [] ->
      Format.fprintf ch "()"
    | e :: rem ->
      print_state_rec ch e y;
      List.iter
        (fun e ->
           Format.fprintf ch "@ | ";
           print_state_rec ch e y)
        rem

  let pp ch t = print_state_lst ch [t] { id = 0; def = Eps }
end

module State = struct
  type t =
    { idx: idx
    ; category: Category.t
    ; desc: E.t list
    ; mutable status: status option
    ; hash: hash }

  let dummy =
    { idx = -1
    ; category = Category.dummy
    ; desc = []
    ; status = None
    ; hash = -1 }

  let hash idx cat desc =
    E.hash desc (hash_combine idx (hash_combine (Category.to_int cat) 0)) land 0x3FFFFFFF

  let mk idx cat desc =
    { idx
    ; category = cat
    ; desc
    ; status = None
    ; hash = hash idx cat desc}

  let create cat e = mk 0 cat [E.TExp (Marks.empty, e)]

  let equal x y =
    (x.hash : int) = y.hash && (x.idx : int) = y.idx &&
    Category.equal x.category y.category && E.equal x.desc y.desc

  let compare x y =
    let c = compare (x.hash : int) y.hash in
    if c <> 0 then c else
      let c = Category.compare x.category y.category in
      if c <> 0 then c else
        compare x.desc y.desc

  type t' = t
  module Table = Hashtbl.Make(
    struct
      type t = t'
      let equal = equal
      let hash t = t.hash
    end)
end

(**** Find a free index ****)

type working_area = bool array ref

let create_working_area () = ref [| false |]

let index_count w = Array.length !w

let reset_table a = Array.fill a 0 (Array.length a) false

let rec mark_used_indices tbl =
  List.iter (function
      | E.TSeq (l, _, _) -> mark_used_indices tbl l
      | E.TExp (marks, _)
      | E.TMatch marks ->
        List.iter (fun (_, i) -> if i >= 0 then tbl.(i) <- true)
          marks.Marks.marks)

let rec find_free tbl idx len =
  if idx = len || not tbl.(idx) then idx else find_free tbl (idx + 1) len

let free_index tbl_ref l =
  let tbl = !tbl_ref in
  reset_table tbl;
  mark_used_indices tbl l;
  let len = Array.length tbl in
  let idx = find_free tbl 0 len in
  if idx = len then tbl_ref := Array.make (2 * len) false;
  idx

(**** Computation of the next state ****)

let remove_matches = List.filter (function E.TMatch _ -> false | _ -> true)

let rec split_at_match_rec l' = function
  | []            -> assert false
  | E.TMatch _ :: r -> (List.rev l', remove_matches r)
  | x :: r        -> split_at_match_rec (x :: l') r

let split_at_match l = split_at_match_rec [] l

let rec remove_duplicates prev l y =
  match l with
    [] ->
    ([], prev)
  | E.TMatch _ as x :: _ -> (* Truncate after first match *)
    ([x], prev)
  | E.TSeq (l', x, kind) :: r ->
    let (l'', prev') = remove_duplicates prev l' x in
    let (r', prev'') = remove_duplicates prev' r y in
    (E.tseq kind l'' x r', prev'')
  | E.TExp (_marks, {def = Eps; _}) as e :: r ->
    if List.memq y.id prev then
      remove_duplicates prev r y
    else
      let (r', prev') = remove_duplicates (y.id :: prev) r y in
      (e :: r', prev')
  | E.TExp (_marks, x) as e :: r ->
    if List.memq x.id prev then
      remove_duplicates prev r y
    else
      let (r', prev') = remove_duplicates (x.id :: prev) r y in
      (e :: r', prev')

let rec set_idx idx = function
  | [] ->
    []
  | E.TMatch marks :: r ->
    E.TMatch (Marks.marks_set_idx marks idx) :: set_idx idx r
  | E.TSeq (l', x, kind) :: r ->
    E.TSeq (set_idx idx l', x, kind) :: set_idx idx r
  | E.TExp (marks, x) :: r ->
    E.TExp ((Marks.marks_set_idx marks idx), x) :: set_idx idx r

let filter_marks b e marks =
  {marks with Marks.marks = List.filter (fun (i, _) -> i < b || i > e) marks.Marks.marks }

let rec delta_1 marks c ~next_cat ~prev_cat x rem =
  (*Format.eprintf "%d@." x.id;*)
  match x.def with
    Cst s ->
    if Cset.mem c s then E.texp marks eps_expr :: rem else rem
  | Alt l ->
    delta_2 marks c ~next_cat ~prev_cat l rem
  | Seq (kind, y, z) ->
    let y' = delta_1 marks c ~next_cat ~prev_cat y [] in
    delta_seq c ~next_cat ~prev_cat kind y' z rem
  | Rep (rep_kind, kind, y) ->
    let y' = delta_1 marks c ~next_cat ~prev_cat y [] in
    let (y'', marks') =
      match
        first
          (function E.TMatch marks -> Some marks | _ -> None) y'
      with
        None        -> (y', marks)
      | Some marks' -> (remove_matches y', marks')
    in
    begin match rep_kind with
        `Greedy     -> E.tseq kind y'' x (E.TMatch marks' :: rem)
      | `Non_greedy -> E.TMatch marks :: E.tseq kind y'' x rem
    end
  | Eps ->
    E.TMatch marks :: rem
  | Mark i ->
    let marks = { marks with Marks.marks = (i, -1) :: List.remove_assq i marks.Marks.marks } in
    E.TMatch marks :: rem
  | Pmark i ->
    let marks = { marks with Marks.pmarks = Pmark.Set.add i marks.Marks.pmarks } in
    E.TMatch marks :: rem
  | Erase (b, e) ->
    E.TMatch (filter_marks b e marks) :: rem
  | Before cat'' ->
    if Category.intersect next_cat cat'' then E.TMatch marks :: rem else rem
  | After cat'' ->
    if Category.intersect prev_cat cat'' then E.TMatch marks :: rem else rem

and delta_2 marks c ~next_cat ~prev_cat l rem =
  match l with
    []     -> rem
  | y :: r ->
    delta_1 marks c ~next_cat ~prev_cat y
      (delta_2 marks c ~next_cat ~prev_cat r rem)

and delta_seq c ~next_cat ~prev_cat kind y z rem =
  match
    first (function E.TMatch marks -> Some marks | _ -> None) y
  with
    None ->
    E.tseq kind y z rem
  | Some marks ->
    match kind with
      `Longest ->
      E.tseq kind (remove_matches y) z
        (delta_1 marks c ~next_cat ~prev_cat z rem)
    | `Shortest ->
      delta_1 marks c ~next_cat ~prev_cat z
        (E.tseq kind (remove_matches y) z rem)
    | `First ->
      let (y', y'') = split_at_match y in
      E.tseq kind y' z
        (delta_1 marks c ~next_cat ~prev_cat z (E.tseq kind y'' z rem))

let rec delta_3 c ~next_cat ~prev_cat x rem =
  match x with
    E.TSeq (y, z, kind) ->
    let y' = delta_4 c ~next_cat ~prev_cat y [] in
    delta_seq c ~next_cat ~prev_cat kind y' z rem
  | E.TExp (marks, e) ->
    delta_1 marks c ~next_cat ~prev_cat e rem
  | E.TMatch _ ->
    x :: rem

and delta_4 c ~next_cat ~prev_cat l rem =
  match l with
    []     -> rem
  | y :: r ->
    delta_3 c ~next_cat ~prev_cat y
      (delta_4 c ~next_cat ~prev_cat r rem)

let delta tbl_ref next_cat char st =
  let prev_cat = st.State.category in
  let (expr', _) =
    remove_duplicates []
      (delta_4 char ~next_cat ~prev_cat st.State.desc [])
      eps_expr in
  let idx = free_index tbl_ref expr' in
  let expr'' = set_idx idx expr' in
  State.mk idx next_cat expr''

(****)

let rec red_tr = function
  | [] | [_] as l ->
    l
  | ((s1, st1) as tr1) :: ((s2, st2) as tr2) :: rem ->
    if State.equal st1 st2 then
      red_tr ((Cset.union s1 s2, st1) :: rem)
    else
      tr1 :: red_tr (tr2 :: rem)

let simpl_tr l =
  List.sort
    (fun (s1, _) (s2, _) -> compare s1 s2)
    (red_tr (List.sort (fun (_, st1) (_, st2) -> State.compare st1 st2) l))

(****)

let prepend_deriv = List.fold_right (fun (s, x) l -> Cset.prepend s x l)

let rec restrict s = function
  | [] -> []
  | (s', x') :: rem ->
    let s'' = Cset.inter s s' in
    if Cset.is_empty s''
    then restrict s rem
    else (s'', x') :: restrict s rem

let rec remove_marks b e rem =
  if b > e then rem else remove_marks b (e - 1) ((e, -2) :: rem)

let rec prepend_marks_expr m = function
  | E.TSeq (l, e', s) -> E.TSeq (prepend_marks_expr_lst m l, e', s)
  | E.TExp (m', e')   -> E.TExp (Marks.merge m m', e')
  | E.TMatch m'       -> E.TMatch (Marks.merge m m')

and prepend_marks_expr_lst m l =
  List.map (prepend_marks_expr m) l

let prepend_marks m =
  List.map (fun (s, x) -> (s, prepend_marks_expr_lst m x))

let rec deriv_1 all_chars categories marks cat x rem =
  match x.def with
  | Cst s ->
    Cset.prepend s [E.texp marks eps_expr] rem
  | Alt l ->
    deriv_2 all_chars categories marks cat l rem
  | Seq (kind, y, z) ->
    let y' = deriv_1 all_chars categories marks cat y [(all_chars, [])] in
    deriv_seq all_chars categories cat kind y' z rem
  | Rep (rep_kind, kind, y) ->
    let y' = deriv_1 all_chars categories marks cat y [(all_chars, [])] in
    List.fold_right
      (fun (s, z) rem ->
         let (z', marks') =
           match
             first
               (function E.TMatch marks -> Some marks | _ -> None)
               z
           with
             None        -> (z, marks)
           | Some marks' -> (remove_matches z, marks')
         in
         Cset.prepend s
           (match rep_kind with
              `Greedy     -> E.tseq kind z' x [E.TMatch marks']
            | `Non_greedy -> E.TMatch marks :: E.tseq kind z' x [])
           rem)
      y' rem
  | Eps ->
    Cset.prepend all_chars [E.TMatch marks] rem
  | Mark i ->
    Cset.prepend all_chars [E.TMatch {marks with Marks.marks = ((i, -1) :: List.remove_assq i marks.Marks.marks)}] rem
  | Pmark _ ->
    Cset.prepend all_chars [E.TMatch marks] rem
  | Erase (b, e) ->
    Cset.prepend all_chars
      [E.TMatch {marks with Marks.marks = (remove_marks b e (filter_marks b e marks).Marks.marks)}] rem
  | Before cat' ->
    Cset.prepend (List.assq cat' categories) [E.TMatch marks] rem
  | After cat' ->
    if Category.intersect cat cat' then Cset.prepend all_chars [E.TMatch marks] rem else rem

and deriv_2 all_chars categories marks cat l rem =
  match l with
    []     -> rem
  | y :: r -> deriv_1 all_chars categories marks cat y
                (deriv_2 all_chars categories marks cat r rem)

and deriv_seq all_chars categories cat kind y z rem =
  if
    List.exists
      (fun (_s, xl) ->
         List.exists (function E.TMatch _ -> true | _ -> false) xl)
      y
  then
    let z' = deriv_1 all_chars categories Marks.empty cat z [(all_chars, [])] in
    List.fold_right
      (fun (s, y) rem ->
         match
           first (function E.TMatch marks -> Some marks | _ -> None)
             y
         with
           None ->
           Cset.prepend s (E.tseq kind y z []) rem
         | Some marks ->
           let z'' = prepend_marks marks z' in
           match kind with
             `Longest ->
             Cset.prepend s (E.tseq kind (remove_matches y) z []) (
               prepend_deriv (restrict s z'') rem)
           | `Shortest ->
             prepend_deriv (restrict s z'') (
               Cset.prepend s (E.tseq kind (remove_matches y) z []) rem)
           | `First ->
             let (y', y'') = split_at_match y in
             Cset.prepend s (E.tseq kind y' z []) (
               prepend_deriv (restrict s z'') (
                 Cset.prepend s (E.tseq kind y'' z []) rem)))
      y rem
  else
    List.fold_right
      (fun (s, xl) rem -> Cset.prepend s (E.tseq kind xl z []) rem) y rem

let rec deriv_3 all_chars categories cat x rem =
  match x with
    E.TSeq (y, z, kind) ->
    let y' = deriv_4 all_chars categories cat y [(all_chars, [])] in
    deriv_seq all_chars categories cat kind y' z rem
  | E.TExp (marks, e) ->
    deriv_1 all_chars categories marks cat e rem
  | E.TMatch _ ->
    Cset.prepend all_chars [x] rem

and deriv_4 all_chars categories cat l rem =
  match l with
    []     -> rem
  | y :: r -> deriv_3 all_chars categories cat y
                (deriv_4 all_chars categories cat r rem)

let deriv tbl_ref all_chars categories st =
  let der = deriv_4 all_chars categories st.State.category st.State.desc
      [(all_chars, [])] in
  simpl_tr (
    List.fold_right (fun (s, expr) rem ->
        let (expr', _) = remove_duplicates [] expr eps_expr in
(*
Format.eprintf "@[<3>@[%a@]: %a / %a@]@." Cset.print s print_state expr print_state expr';
*)
        let idx = free_index tbl_ref expr' in
        let expr'' = set_idx idx expr' in
        List.fold_right (fun (cat', s') rem ->
            let s'' = Cset.inter s s' in
            if Cset.is_empty s''
            then rem
            else (s'', State.mk idx cat' expr'') :: rem)
          categories rem) der [])

(****)

let flatten_match m =
  let ma = List.fold_left (fun ma (i, _) -> max ma i) (-1) m in
  let res = Array.make (ma + 1) (-1) in
  List.iter (fun (i, v) -> res.(i) <- v) m;
  res

let status s =
  match s.State.status with
    Some st ->
    st
  | None ->
    let st =
      match s.State.desc with
        []              -> Failed
      | E.TMatch m :: _ -> Match (flatten_match m.Marks.marks, m.Marks.pmarks)
      | _               -> Running
    in
    s.State.status <- Some st;
    st