(*---------------------------------------------------------------------------*
  IMPLEMENTATION  cf_dfa.ml

  Copyright (c) 2002-2004, James H. Woodyatt
  All rights reserved.

  Redistribution and use in source and binary forms, with or without
  modification, are permitted provided that the following conditions
  are met:

    Redistributions of source code must retain the above copyright
    notice, this list of conditions and the following disclaimer.

    Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in
    the documentation and/or other materials provided with the
    distribution

  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
  OF THE POSSIBILITY OF SUCH DAMAGE.
 *---------------------------------------------------------------------------*)

class ['i] cursor pos =
    object(_:'self)
        inherit ['i] Cf_parser.cursor pos
        
        method error (_: int) (_: ('i * 'self) Cf_seq.t) = ()
    end

module NFA_state = struct
    type t = int

    module Order = Cf_ordered.Int_order
    module Map = Cf_rbtree.Map(Order)
    module Set = Cf_rbtree.Set(Order)
end

type y = {
    y_counter_: int;
    y_first_: NFA_state.Set.t;
    y_last_: NFA_state.Set.t;
    y_follow_: Obj.t NFA_state.Map.t -> Obj.t NFA_state.Map.t;
}

type x = {
    x_null_: bool;
    x_cons_: int -> y;
}

let nil_ =
    let cons i = {
        y_counter_ = i;
        y_first_ = NFA_state.Set.nil;
        y_last_ = NFA_state.Set.nil;
        y_follow_ = Obj.magic;
    }
    in {
        x_null_ = true;
        x_cons_ = cons;
    }

class virtual ['action] satisfier =
    object(_:'self)
        val state_ = NFA_state.Set.nil
        
        method virtual edge: int -> NFA_state.Set.t -> NFA_state.Set.t
        method follow s = {< state_ = NFA_state.Set.union state_ s >}
        method accept x = (x : 'action)
    end

class ['action] acceptor f =
    object(self:'self)
        constraint 'action =
            (int -> ('i #cursor, 'i, 'o) Cf_parser.X.t) option
        
        inherit ['action] satisfier
        
        method edge _ u = u
        method follow _ = (self :> 'self)
        method accept = function None -> Some f | x -> x
    end

class ['action] literal i =
    object(self)
        inherit ['action] satisfier
        
        method edge sym u =
            if sym = i then NFA_state.Set.union state_ u else u
    end

class ['action] mapped f =
    object(self)
        inherit ['action] satisfier
        
        method edge sym u =
            if f sym then NFA_state.Set.union state_ u else u
    end

let node_ n =
    let _ = (n :> 'action satisfier) in
    let cons i =
        let s = NFA_state.Set.singleton i in {
            y_counter_ = succ i;
            y_first_ = s;
            y_last_ = s;
            y_follow_ = Obj.magic (NFA_state.Map.replace (i, n));
        }
    in {
        x_null_ = false;
        x_cons_ = cons;
    }

type ('i, 'o) suspension_t = {
    s_accept_: (int -> ('i cursor, 'i, 'o) Cf_parser.X.t) option;
    s_next_: ('i, 'o) suspension_t Lazy.t array;
}

module DFA_state = struct
    type t = int array

    module Order = struct
        type t = int array
        let compare = Pervasives.compare
    end

    module Map = Cf_rbtree.Map(Order)
end

exception Unrecognized

module type Symbol_T = sig
    type t
    val size: int
    val to_int: t -> int
    val of_int: int -> t
end

module type T = sig
    module S: Symbol_T

    type ('c, 'x) t = ('c, S.t, 'x) Cf_parser.X.t constraint 'c = S.t #cursor

    type expr_t
    type ('c, 'x) rule_t constraint 'c = S.t #cursor

    val nil: expr_t

    module Op: sig
        val ( $| ): expr_t -> expr_t -> expr_t
        val ( $& ): expr_t -> expr_t -> expr_t
        val ( !* ): expr_t -> expr_t
        val ( !+ ): expr_t -> expr_t
        val ( !? ): expr_t -> expr_t

        val ( !: ): S.t -> expr_t
        val ( !^ ): (S.t -> bool) -> expr_t
        val ( !~ ): S.t Cf_seq.t -> expr_t

        val ( $= ): expr_t -> 'x -> ('c, 'x) rule_t
        val ( $> ): expr_t -> (S.t Cf_seq.t -> 'x) -> ('c, 'x) rule_t
        val ( $@ ): expr_t -> (int -> ('c, 'x) t) -> ('c, 'x) rule_t
        
        val ( !@ ): ('c, 'x) rule_t list -> ('c, 'x) rule_t
    end
    
    val create: ('c, 'x) rule_t -> ('c, 'x) t
end

module Create(S: Symbol_T) : (T with module S = S) = struct
    if S.size < 1 then
        invalid_arg "Cf_dfa.Create(S): size < 1";;

    module S = S

    type ('c, 'o) t = ('c, S.t, 'o) Cf_parser.X.t constraint 'c = S.t #cursor

    type expr_t = x
    type ('c, 'x) rule_t = x constraint 'c = S.t #cursor
    
    let nil = nil_
    
    module Op = struct
        let union_follow_ y0 y1 w = y1.y_follow_ (y0.y_follow_ w)
    
        let ( $| ) x0 x1 =
            let cons i =
                let y0 = x0.x_cons_ i in
                let y1 = x1.x_cons_ y0.y_counter_ in {
                    y_counter_ = y1.y_counter_;
                    y_first_ = NFA_state.Set.union y0.y_first_ y1.y_first_;
                    y_last_ = NFA_state.Set.union y0.y_last_ y1.y_last_;
                    y_follow_ = union_follow_ y0 y1;
                }
            in {
                x_null_ = x0.x_null_ || x1.x_null_;
                x_cons_ = cons;
            }
        
        let follow_fold_aux_ a w i =
            assert (NFA_state.Map.member i w);
            let n = Obj.obj (NFA_state.Map.search i w) in
            let _ = (n :> 'action satisfier) in
            let n = Obj.repr (n#follow a) in
            NFA_state.Map.replace (i, n) w
        
        let cat_follow_ y0 y1 w =
            let w = y0.y_follow_ w in
            let w = y1.y_follow_ w in
            NFA_state.Set.fold (follow_fold_aux_ y1.y_first_) w y0.y_last_
    
        let ( $& ) x0 x1 =
            let cons i =
                let y0 = x0.x_cons_ i in
                let y1 = x1.x_cons_ y0.y_counter_ in
                let first =
                    if x0.x_null_ then
                        NFA_state.Set.union y0.y_first_ y1.y_first_
                    else
                        y0.y_first_
                and last =
                    if x1.x_null_ then
                        NFA_state.Set.union y0.y_last_ y1.y_last_
                    else
                        y1.y_last_
                in {
                    y_counter_ = y1.y_counter_;
                    y_first_ = first;
                    y_last_ = last;
                    y_follow_ = cat_follow_ y0 y1;
                }
            in {
                x_null_ = x0.x_null_ && x1.x_null_;
                x_cons_ = cons; 
            }
        
        let star_follow_ y w =
            let w = y.y_follow_ w in
            NFA_state.Set.fold (follow_fold_aux_ y.y_first_) w y.y_last_

        let ( !* ) x =
            let cons i =
                let y = x.x_cons_ i in { y with y_follow_ = star_follow_ y }
            in {
                x_null_ = true;
                x_cons_ = cons;
            }
        
        let ( !? ) x = x $| nil_
        let ( !+ ) x = x $& (!* x)

        let ( !: ) sym = node_ (new literal (S.to_int sym))
        let ( !^ ) f = node_ (new mapped (fun sym -> f (S.of_int sym)))
        
        let rec ( !~ ) s =
            match Lazy.force s with
            | Cf_seq.Z -> nil_
            | Cf_seq.P (x, tl) -> !:x $& !~tl

        let ( $= ) expr lit =
            let f n z = Some (lit, Cf_seq.shift n z) in
            expr $& (node_ (new acceptor f))
    
        let ( $> ) expr action =
            let f n z =
                let hd = Cf_seq.limit n (Cf_seq.map fst z)
                and tl = Cf_seq.shift n z in
                Some (action hd, tl)
            in
            expr $& (node_ (new acceptor f))
    
        let ( $@ ) expr f =
            expr $& (node_ (new acceptor f))

        let ( !@ ) =
            let rec loop e rs =
                match rs with
                | hd :: tl -> loop (hd $| e) tl
                | [] -> e
            in
            fun rs -> loop nil_ rs
    end
    
    let suspend_ x =
        let y = x.x_cons_ 0 in
        let w = y.y_follow_ NFA_state.Map.nil in
        let h = ref DFA_state.Map.nil in
        let g1 sym u p =
            let n = Obj.obj (NFA_state.Map.search p w) in
            let _ = (n :> 'action #satisfier) in
            n#edge sym u
        in
        let g2 a p =
            let n = Obj.obj (NFA_state.Map.search p w) in
            let _ = (n :> 'action #satisfier) in
            n#accept a
        in
        let rec state u =
            let edge i =
                lazy begin
                    let v = Array.fold_left (g1 i) NFA_state.Set.nil u in
                    if NFA_state.Set.empty v then raise Unrecognized;
                    let u = Array.of_list (NFA_state.Set.to_list_incr v) in
                    try DFA_state.Map.search u !h with Not_found -> state u
                end
            in
            let s = {
                s_accept_ = Array.fold_left g2 None u;
                s_next_ = Array.init S.size edge;
            } in
            h := DFA_state.Map.replace (u, s) !h;
            s
        in
        state (Array.of_list (NFA_state.Set.to_list_incr y.y_first_))
    
    let s_accept_ susp acc lim z0 =
        match susp.s_accept_ with
        | None -> acc
        | Some action -> lazy ((Obj.magic action) lim z0)
    
    let create =
        let rec loop ~z0 ~lim acc susp seq =
            match Lazy.force seq with
            | Cf_seq.Z ->
                Lazy.force acc
            | Cf_seq.P ((i, c), tl) ->
                let next = susp.s_next_.(S.to_int i) in
                match try Some (Lazy.force next) with Unrecognized -> None with
                | Some susp ->
                    let lim = succ lim in
                    let acc = s_accept_ susp acc lim z0 in
                    loop ~z0 ~lim acc susp tl
                | None ->
                    match Lazy.force acc with
                    | Some _ as v -> v
                    | None -> c#error lim z0; None
        in
        fun dfa ->
            let susp = suspend_ dfa in
            fun z0 ->
                let acc = s_accept_ susp (Lazy.lazy_from_val None) 0 z0 in
                loop ~z0 ~lim:0 acc susp z0
end

(*--- End of File [ cf_dfa.ml ] ---*)