(*
    HLins: insert http-links into HTML documents.
    See http://www.lri.fr/~treinen/hlins

    Copyright (C) 1999 Ralf Treinen <treinen@lri.fr>

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

    This program 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 General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

*)


open Array;;
open Automaton;;
open Names;;

(* see automaton.ml for the explication of the type automaton *)	  


(* (ins_word root tree level firstfree i l s abbrev) where s is a word
   of length l and i<=l, stores the subword of s starting at position
   i in tree and level where root is assumed to be the root
   node. firstfree is the first unused node. abbrev is true if s is an
   abbreviation and false otherwise.  Returns the pair (n,m) where n
   is the node with path(n)=s, and m is the first unused node.
*)

let rec ins_word root tree level suf found expand firstfree i l s ind
  abbrev  =

  (* fresh_ins_word does the same thing than ins_word in the special
     case where we already know that root is a fresh node. The parameter
     firstfree is not needed since we know that it must be equal to root+1
  *)
  
     let rec fresh_ins_word root tree level suf found expand i l s ind
       abbrev  =  
       if i=l
       then 
	 begin
	   suf.(root) <- root;
	   if abbrev
	   then expand.(root) <- ind::expand.(root)
	   else found.(root) <- ind::found.(root);
	   root+1
	 end
       else
	 let rootinc = root + 1
	 in
	   begin
	     tree.(root) <-
	     add_transition tree.(root) (String.get s i) rootinc;
	     level.(rootinc) <- i+1;
	     fresh_ins_word rootinc tree level suf found expand (i+1)
	       l s ind abbrev  
	   end
     in
       if i=l
       then
	 begin 
	   suf.(root) <- root;
	   if abbrev
	   then expand.(root) <- ind::expand.(root)
	   else found.(root) <- ind::found.(root);
	   firstfree
	 end
       else
	 try
	   ins_word (get_transition tree.(root) (String.get s i) )
	     tree level suf found expand firstfree (i+1) l s ind
	     abbrev
	 with Not_found ->
	   begin
	     tree.(root) <-
	     add_transition tree.(root) (String.get s i) firstfree;
	     level.(firstfree) <- i+1;
	     fresh_ins_word firstfree tree level suf found expand
	       (i+1) l s ind abbrev
	   end;;
	   

(* (ins_abbrevs tree level suf found firstfree l i) inserts all words
   of l, considered as abbreviations of the word with index i, into
   tree, level, suf, found.  element of l. Returns the first unused
   node.  *)

let rec ins_abbrev tree level suf found expand firstfree l i =
  match l with
      [] -> firstfree
    | h::r ->
	let newfirstfree =
	  ins_word 0 tree level suf found expand firstfree 0
	    (String.length h) h i true
	in
	  ins_abbrev tree level suf found expand newfirstfree r i
;;
	    

(* (ins_list tree level suf found firstfree l i) inserts all words of l
   into tree, level, suf, found. i is the index number of the first
   element of l. Returns the first unused node.
*)

let rec ins_list tree level suf found expand firstfree l i =
  match l with
      [] -> firstfree
    | (name::abbrevs,_)::r ->
	let newfirstfree =
	  ins_word 0 tree level suf found expand firstfree 0
	    (String.length name) 
	    name i false
	in
	let anewfirstfree =
	  ins_abbrev tree level suf found expand newfirstfree abbrevs i 
	in
	  ins_list tree level suf found expand anewfirstfree r (i+1)
    | _ -> failwith "This cannot happen (Build_automaton.ins_list)"
;;



(* (propagate tree board suf l ll) propagates the board function for
   all nodes in l@ll to their respective sons. The second argument is
   used as an accumulating parameter for new propagation tasks.
*)


let rec propagate tree board suf l ll = 

  (* (setboard tree board suf z c s), where s is a son at edge c and z
     is an iterated board of the father of s, sets the board of s
     under the hypothesis that the board of all its ancestors is
     set. returns s.
  *)

  let rec setboard tree board suf z c s =
       if z = -1
       then
	 begin
	   board.(s) <- 0;
	   s
	 end
       else
	 try
	   let b = get_transition tree.(z) c
	   in begin
	     board.(s) <- b;
	     if suf.(s) <> s then suf.(s) <- suf.(b);
	     s
	   end
	 with Not_found -> setboard tree board suf board.(z) c s 

  in

    match l with
	[] -> (match ll with
		   [] -> ()
		 | _ -> propagate tree board suf ll l)
      | h::r -> propagate tree board suf r
	  (transitions_fold
	     (fun l c s -> (setboard tree board suf board.(h) c s)::l)
	     ll tree.(h))
	    


let build l =
  let el = List.map abbreviate l
  in let size = (List.fold_right (fun (l,n) m -> n + m) el 1 )
     and maxl = (List.fold_right (fun (l,n) m -> max n m) el 0 )
  in let suf = init size (function i -> 0)
     and level = init size (function i -> 0)
     and tree = init size (function i-> empty_transitions ) 
     and board = init size (function i -> 0)
     and found = init size (function i -> [])
     and expand = init size (function i -> [])
     in
       begin
	 (* build level and tree *)
	 let n = ins_list tree level suf found expand 1 el 0
	 in
	   begin
	     (* compute board and suf *)
	     board.(0) <- -1;
	     suf.(0) <- -1;
	     propagate tree board suf [0] [];
	     
	     {number_of_states=n;
	      max_path_length = maxl;
	      level=level;
	      tree=tree;
	      board=board;
	      suf=suf;
	      found=found;
	      expand=expand
	     }
	   end
       end
;;














