(* $Id: xstr_match.ml,v 1.9 2002/07/07 11:27:16 gerd Exp $
 * ----------------------------------------------------------------------
 * String matching 
 *)


type variable =
    { mutable sref : string;
      mutable found : bool;
      mutable begun : bool;
      mutable from : int;
      mutable len : int
    } 
;;


type charset = int array;;


type matcher =
    Literal of string
  | Anystring 
  | Lazystring 
  | Anychar
  | Anystring_from of charset
  | Lazystring_from of charset
  | Anychar_from of charset
  | Nullstring
  | Alternative of matcher list list
  | Optional of matcher list
  | Record of (variable * matcher list)
  | Scanner of (string -> int)
;;


(**********************************************************************)

(* operations on sets *)

(* copied from the JavaCaml regexp implementation *)

let the_full_set = Array.create 16 0xffff;;
let the_empty_set = Array.create 16 0;;

let dup_set s =
  Array.copy s
;;


let empty_set () =
  the_empty_set
;;


let full_set () =
  the_full_set
;;


let ( +! ) a b =
  (* union *)
  let r = Array.create 16 0 in
  for i=0 to 15 do
    r.(i) <- a.(i) lor b.(i)
  done;
  r
;;


let ( *! ) a b =
  (* intersection *)
  let r = Array.create 16 0 in
  for i=0 to 15 do
    r.(i) <- a.(i) land b.(i)
  done;
  r
;;


let ( !! ) a =
  (* negation *)
  let r = Array.create 16 0 in
  for i=0 to 15 do
    r.(i) <- a.(i) lxor 0xffff
  done;
  r
;;


let ( ?! ) a =
  (* not null? *)
  let n = ref 0 in
  for i=0 to 15 do
    n := !n lor a.(i)
  done;
  !n <> 0
;;


let set_include a n =
  (* include in set -- this is in-place modification! *)
  a.( n lsr 4 ) <- a.( n lsr 4 ) lor (1 lsl (n land 15))
;;


let set_exclude a n =
  (* exclude from set -- this is in-place modification! *)
  a.( n lsr 4 ) <- a.( n lsr 4 ) land ((1 lsl (n land 15)) lxor 0xffff)
;;


let member_of_set n a =
(*  (a.( n lsr 4 ) land (1 lsl (n land 15))) <> 0 *)
  (a.( n lsr 4 ) lsr (n land 15)) land 1 <> 0
;;


let word_set() =
  let a = dup_set (empty_set()) in
  List.iter
    (fun c ->
      set_include a (Char.code c))
    [ 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; 'g'; 'h'; 'i'; 'j'; 'k'; 'l'; 'm';
      'n'; 'o'; 'p'; 'q'; 'r'; 's'; 't'; 'u'; 'v'; 'w'; 'x'; 'y'; 'z';
      'A'; 'B'; 'C'; 'D'; 'E'; 'F'; 'G'; 'H'; 'I'; 'J'; 'K'; 'L'; 'M';
      'N'; 'O'; 'P'; 'Q'; 'R'; 'S'; 'T'; 'U'; 'V'; 'W'; 'X'; 'Y'; 'Z';
      '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9';
      '_' ];
  a
;;


let noword_set() =
  let a = word_set() in
  !! a
;;
    

let set_as_string set =
  let s = String.make 32 ' ' in
  for i = 0 to 15 do
    s.[i+i]   <- Char.chr (set.(i) land 0xff);
    s.[i+i+1] <- Char.chr (set.(i) lsr 8);
  done;
  s
;;


(**********************************************************************)


exception Found of variable list
;;


let rec first_character ml =
  (* return a set of characters s: all non-empty strings that ml matches have
   * initial characters that are element of s; if ml matches the empty string 
   * then full_set() is returned.
   *)
  match ml with
    [] -> full_set()
  | Literal "" :: ml' -> first_character ml'
  | Literal s :: _ -> 
      let cs = dup_set(empty_set()) in
      set_include cs (Char.code s.[0]);
      cs
  | Anystring :: _ -> full_set()
  | Lazystring :: _ -> full_set()
  | Anychar :: _ -> full_set()
  | Anystring_from s :: _ -> full_set()
  | Lazystring_from s :: _ -> full_set()
  | Anychar_from s :: _ -> s
  | Nullstring :: ml' -> first_character ml'
  | Alternative l :: _ ->
      List.fold_left
	(fun s x -> s +! (first_character x))
	(empty_set())
	l
  | Optional ml1 :: ml2 -> (first_character ml1) +! (first_character ml2)
  | Record (v,ml1) :: ml2 -> first_character ml1
  | Scanner f :: _ -> full_set()
;;


let match_string_at ml s k =
  
  let len = String.length s in

  let rec run k ml recs =
    (* returns () meaning that nothing has been found, or
     * Found recs'.
     * 'k': position in s
     * 'ml': matcher list to process
     * 'recs': recorded sections up to now
     * 'Some recs'': total list of recorded sections
     *)
    match ml with
      [] ->
	if k = len then
	  raise(Found recs)
    | Literal x :: ml' ->
	let xlen = String.length x in
	begin match xlen with
	  0 -> run k ml' recs
	| 1 -> if k+1 <= len && s.[k] = x.[0] then run (k+1) ml' recs
	| 2 -> if k+2 <= len && s.[k] = x.[0] && s.[k+1] = x.[1] then 
	       run (k+2) ml' recs
	| 3 -> if k+3 <= len && s.[k] = x.[0] && s.[k+1] = x.[1] &&
	          s.[k+2] = x.[2] then 
	       run (k+3) ml' recs
	| 4 -> if k+4 <= len && s.[k] = x.[0] && s.[k+1] = x.[1] &&
	          s.[k+2] = x.[2] && s.[k+3] = x.[3] then 
	       run (k+4) ml' recs
	| _ -> if k + xlen <= len && String.sub s k xlen = x then
	       run (k+xlen) ml' recs
	          (* this is still not optimal *)
	end
    | Anystring :: ml' ->
	run len ml' recs;
	let ml'fc = first_character ml' in
	let rec find n =
	  if n >= 0 then begin
	    if member_of_set (Char.code s.[k+n]) ml'fc then
	      run (k+n) ml' recs;
	    find (n-1)
	  end
	in
	find (len-k-1)
    | Lazystring :: ml' ->
	let ml'fc = first_character ml' in
	let max = len-k in
	let max3 = max - 3 in
	let rec find n =
	  if n < max3 then begin
	    let c1 = Char.code s.[k+n] in
	    if member_of_set c1 ml'fc then 
	      run (k+n) ml' recs;
	    let c2 = Char.code s.[k+n+1] in
	    if member_of_set c2 ml'fc then
	      run (k+n+1) ml' recs;
	    let c3 = Char.code s.[k+n+2] in
	    if member_of_set c3 ml'fc then
	      run (k+n+2) ml' recs;
	    let c4 = Char.code s.[k+n+3] in
	    if member_of_set c4 ml'fc then
	      run (k+n+3) ml' recs;
	    find (n+4)
	  end
	  else if n <= max then begin
	    run (k+n) ml' recs;
	    find (n+1)
	  end
	in
	find 0
    | Anystring_from set :: ml' ->
	let rec region n =
	  if k+n < len then
	    let c = Char.code (s.[k+n]) in
	    if member_of_set c set then
	      region (n+1)
	    else
	      n
	  else
	    n
	in
	let max = region 0 in
	run (k+max) ml' recs;
	let ml'fc = first_character ml' in
	let rec find n =
	  if n >= 3 then begin
	    if member_of_set (Char.code s.[k+n]) ml'fc then
	      run (k+n) ml' recs;
	    if member_of_set (Char.code s.[k+n-1]) ml'fc then
	      run (k+n-1) ml' recs;
	    if member_of_set (Char.code s.[k+n-2]) ml'fc then
	      run (k+n-2) ml' recs;
	    if member_of_set (Char.code s.[k+n-3]) ml'fc then
	      run (k+n-3) ml' recs;
	    find (n-4)
	  end
	  else if n >= 0 then begin
	    if member_of_set (Char.code s.[k+n]) ml'fc then
	      run (k+n) ml' recs;
	    find (n-1)
	  end
	in
	find (max-1)
    | Lazystring_from set :: ml' ->
	let rec region n =
	  if k+n < len then
	    let c = Char.code (s.[k+n]) in
	    if member_of_set c set then
	      region (n+1)
	    else
	      n
	  else
	    n
	in
	let max = region 0 in
	let ml'fc = first_character ml' in
	let rec find n =
	  if n < max then begin
	    if member_of_set (Char.code s.[k+n]) ml'fc then
	      run (k+n) ml' recs;
	    find (n+1)
	  end 
	  else if n = max then
	    run (k+max) ml' recs
	in
	find 0
    | Anychar :: ml' ->
	if k < len then
	  run (k+1) ml' recs
    | Anychar_from set :: ml' ->
	if k < len then
	  let c = Char.code (s.[k]) in
	  if member_of_set c set then 
	    run (k+1) ml' recs
    | Nullstring :: ml' ->
	run k ml' recs
    | Alternative alts :: ml' ->
	let rec find alts =
	  match alts with
	    [] -> ()
	  | alt :: alts' ->
	      run k (alt @ ml') recs;
	      find alts'
	in
	find alts
    | Optional opt :: ml' ->
	run k (opt @ ml') recs;
	run k ml' recs
    | Record (r, recorded) :: ml' ->
	if r.found then
	  failwith "string_match: the same variable matches twice";
	if r.begun then begin (* ==> recorded = [] *)
	  let old_len = r.len in
	  r.found <- true;
	  r.len <- k - r.from;
	  run k ml' (r::recs);
	  r.found <- false;
	  r.len <- old_len
	end
	else begin
	  let old_from = r.from in
	  r.begun <- true;
	  r.from <- k;
	  run k (recorded @ (Record(r,[]) :: ml')) recs;
	  r.begun <- false;
	  r.from <- old_from
	end
    | Scanner f :: ml' ->
	let n = f (String.sub s k (len-k)) in
	if k+n > len then
	  failwith "match";
	run (k+n) ml' recs

  in

  try
    let recs = 
      try run k ml []; raise Not_found 
      with
      	Found r -> r
    in

    List.iter
      (fun r ->
	if r.found then
	  r.sref <- s)
      recs;
    true
  with
    Not_found ->
      false
;;


let match_string ml s =
  let rec reset ml =
    match ml with
      [] -> ()
    | Alternative alts :: ml' ->
	List.iter reset alts;
	reset ml'
    | Optional opt :: ml' ->
	reset opt;
	reset ml'
    | Record (v,r) :: ml' ->
	v.found <- false;
	v.begun <- false;
	reset r;
	reset ml'
    | _ :: ml' ->
	reset ml'
  in

  reset ml;
  match_string_at ml s 0
;;



let var s =
  { sref = s; found = false; begun = false; from = 0; len = String.length s }
;;



type replacer =
    ReplaceLiteral of string
  | ReplaceVar of variable
  | ReplaceFunction of (unit -> string)
;;


type rflag =
    Anchored
  | Limit of int
;;


type repl =
    RLit of string
  | RRegion of (int * int)
;;


exception Limit_exceeded;;


let replace_matched_substrings ml rl fl s =
  let anchored = List.mem Anchored fl in
  let all = var "" in
  let ml' = [ Record(all, ml)] @ (if anchored then [] else [ Anystring ]) in

  let rec resetlist ml =
    match ml with
      [] -> []
    | Alternative alts :: ml' ->
	List.flatten (List.map resetlist alts) @
	resetlist ml'
    | Optional opt :: ml' ->
	resetlist opt @
	resetlist ml'
    | Record (v,r) :: ml' ->
	v :: (resetlist r @ resetlist ml')
    | _ :: ml' ->
	resetlist ml'
  in

  let resl = resetlist ml' in
  let limit = 
    List.fold_left 
      (fun m f ->
	match f with
	  Limit n -> 
	    if n < 0 then failwith "replace_matched_substrings";
	    if m >= 0 then min m n else n
	| _       -> m)
      (-1)
      fl in

  let n_repl = ref 0 in

  let replace_at k =
    if limit >= 0 && !n_repl >= limit then
      [], (-1)
    else begin
      List.iter
	(fun v -> 
	  v.found <- false;
	  v.begun <- false)
	resl;
      if match_string_at ml' s k then begin
        (* interpret rl *)
	try
	  let repltext =
	    List.map
	      (fun r ->
		match r with
		  ReplaceLiteral s -> RLit s
		| ReplaceVar v -> 
		    if v.found then
		      RRegion (v.from, v.len)
		    else
		      RLit ""
		| ReplaceFunction f ->
		    begin try
		      RLit (f ())
		    with
		      Not_found -> 
			raise Not_found
		    | Match_failure (_,_,_) ->
			raise Not_found
		    end) 
	      rl
	  in
	  let amount = all.len in
	  incr n_repl;
	  repltext, amount
	with
	  Not_found -> [], (-1)
      end
      else [], (-1)
    end
  in

  let l = String.length s in

  let ml'fc = first_character ml' in

  let rec left_to_right trans k_gapstart k =
    let rec ltor k =
      if k < (l-1) then begin
	if not (member_of_set (Char.code s.[k]) ml'fc ) then begin
	  if not (member_of_set (Char.code s.[k+1]) ml'fc ) then begin
	    ltor (k+2)
	  end
	  else try_match trans k_gapstart (k+1)
	end
	else try_match trans k_gapstart k
      end
      else
	if k <= l then 
          (* Note k<=l: this criterion could be much better *)
	  try_match trans k_gapstart k
	else
	  RRegion(k_gapstart, k-k_gapstart-1) :: trans
    in
    ltor k

  and try_match trans k_gapstart k =
    let repltext, amount = replace_at k in
    if amount >= 0 then begin
      left_to_right
	(repltext @ [RRegion(k_gapstart, k-k_gapstart)] @ trans)
	(k + amount)
	(if amount=0 then k+1 else k+amount)
    end 
    else
      left_to_right trans k_gapstart (k+1)
    
  in

  let with_anchors () =
    try
      let repltext, amount = replace_at 0 in
      repltext 
    with
      Not_found ->
	[ RRegion(0, l) ]
    | Limit_exceeded ->
	[ RRegion(0, l) ]
  in

  let rec total_length n trans =
    match trans with
      RLit s :: trans' ->
	total_length (n+String.length s) trans'
    | RRegion (_,len) :: trans' ->
	total_length (n+len) trans'
    | [] ->
	n
  in

  let rec form_replacement_ltor target trans j =
    match trans with
      RLit t :: trans' ->
	let ls = String.length t in
	let j' = j - ls in
	if ls > 0 then String.blit t 0 target j' ls;
	form_replacement_ltor target trans' j'
    | RRegion (from,len) :: trans' ->
	let j' = j - len in
	if len > 0 then String.blit s from target j' len;
	form_replacement_ltor target trans' j'
    | [] -> ()
  in

  (* TODO: interpret rtol, 
   * what's with initialization of variables?
   *)

  let transformer = 
    if anchored then
      with_anchors()
    else
      left_to_right [] 0 0 
  in
  let length = total_length 0 transformer in
  let target = String.create length in
  form_replacement_ltor target transformer length;
  target, !n_repl
;;
  


let var_matched v =
  v.found
;;


let string_of_var v =
  String.sub v.sref v.from v.len
;;


let found_string_of_var v =
  if v.found then String.sub v.sref v.from v.len else raise Not_found
;;


let mkset s =
  let l = String.length s in
  let k = ref (-1) in
  let c = ref ' ' in

  let next_noesc() =
    incr k;
    if ( !k < l ) then begin
      c := s.[ !k ];
    end
  in

  let set = dup_set (empty_set()) in

  let add_char c =
    let code = Char.code c in
    set_include set code
  in

  let add_range c1 c2 =
    let code1 = Char.code c1 in
    let code2 = Char.code c2 in
    for i = code1 to code2 do
      set_include set i
    done
  in

  let continue = ref true in
  next_noesc();

  while !continue && !k < l do
    match () with
    | () when (!k + 2 < l) && (s.[!k + 1] = '-') ->

        (* range *)

	add_range !c (s.[!k + 2]);
	next_noesc();
	next_noesc();
	next_noesc();

    | () ->
	add_char !c;
	next_noesc();
  done;

  set
;;


let mknegset s =
  !! (mkset s)
;;


(* ======================================================================
 * History:
 * 
 * $Log: xstr_match.ml,v $
 * Revision 1.9  2002/07/07 11:27:16  gerd
 * 	Fixed Xstr_match.mkset
 *
 * Revision 1.8  2000/09/23 13:43:22  gerd
 * 	Bugfix in replace_matched_substrings.
 *
 * Revision 1.7  1999/07/08 02:41:10  gerd
 * 	Bugfix in 'Record' matching: the variable was not reset to
 * its old values in the case the matching fails.
 *
 * Revision 1.6  1999/07/06 21:29:33  gerd
 * 	Optimizations in the 'replace_matched_substrings' function.
 *
 * Revision 1.5  1999/07/06 00:47:53  gerd
 * 	Added optimization 'first_character'.
 * 	Now 'run' raises an exception in the case of a success, and
 * otherwise returns () - the exact opposite as before.
 * 	Many more optimizations for 'match_string'.
 *
 * Revision 1.4  1999/07/05 22:34:57  gerd
 * 	match_string: simplifications; now much more tail recursions.
 *
 * Revision 1.3  1999/07/05 21:42:46  gerd
 * 	Bugfix: When Record(_,_) records in a loop, the state of the
 * variable was not cleared after every cycle. This is done now.
 *
 * Revision 1.2  1999/07/04 20:02:07  gerd
 * 	Added Lazystring, Lazystring_from.
 * 	Added replace_matched_substring function.
 * 	Changed the structure of 'variable'. 'sref' is either an arbitrary
 * string, or it is the input string of the matching function. 'from' and
 * 'len' are always used.
 *
 * Revision 1.1  1999/06/27 23:03:37  gerd
 * 	Initial revision.
 *
 * 
 *)
