(*
    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 Str;;
open String;;

(* (products <sep> l1 l2) yields the list of strings of the form
   s1<sep>s2 where si is an element of list li. The first element of
   the result list is obtained from the first element of l1 and l2,
   respectively.
*)
let rec products sep l1 l2 = match l1 with
  | h::r -> (List.map (function s -> h^sep^s) l2) @ (products sep r l2)
  | [] -> []
;;

(* (allproducts <sep> [l1;...;ln]) yields the list of strings of the
   form s1<sep>s2<sep>...<sep>sn where si is an element of list
   li. The first element of the result list is the string obtained
   from the respective first elements of the input lists.
*)
let rec allproducts sep = function
    [h] -> h
  | h::r -> (products sep h (allproducts sep r))
  | [] -> []
;;


(* abbreviation of a last name: the name itself plus, in case of a
   composite name, the first component.
*)
let abbreviate_lastname name =
  try
    [ name ; string_before name (rindex name '-') ]
  with
      Not_found -> [name]
;;


(* list of abbreviations of a non-composite first name, starting with
   the name itself.
*)
let abbreviate_simple_firstname s =
  if length s <= 1 or get s (length s - 1) = '.'
  then [s]
  else if sub s 0 2 = "St" && length s > 2
  then [s;"S.";"St."]
  else if sub s 0 2 = "Ch" && length s > 2
  then [s;"C.";"Ch."]
  else [s;(sub s 0 1)^"."]
;;


(* abbreviate a first name which may contain a dash *)
let abbreviate_firstname s =
  try 
    let n = rindex s '-'
    in s :: products "-"
	 (List.tl (abbreviate_simple_firstname (string_before s n)))
	 (List.tl (abbreviate_simple_firstname (string_after s (n + 1))))
  with
      Not_found -> (abbreviate_simple_firstname s)
;;


(* (expand_namelist l), where l is the non-empty list of parts of a
   name, yields the list of lists of abbreviation of these parts.
*)
let rec expand_namelist = function
  | [s] ->
      if get s 0 = '<' && get s (length s - 1) = '>'
      then [[(sub s 1 (length s - 2))]]
      else [abbreviate_lastname s]
  | s::r ->
      (if get s 0 = '<' && get s (length s - 1) = '>'
       then [(sub s 1 (length s - 2))]
       else abbreviate_firstname s) :: (expand_namelist r)
  | [] -> failwith "this cannot happen" ;;


(* (pathlength l), where l is obtained as result of expand_name,
   returns the number of nodes in the tree.
*)
let rec pathlength = function
  | [h] ->
      String.length (List.hd h)
	(* h contains the abbreviations of the last name (hd h) which are
	   hence all prefixes of (hd h), that is h does not count for the
	   size of the tree. *)
  | h::r ->
      (List.fold_left (fun n s -> n + String.length s) 0 h) 
      + (List.length h) * (1 + pathlength r)
	(* h is a list of abbreviations of first names. We assume the
	   worst case that the tree diverges from the beginning. Hence
	   we have a treenode for every position in a word in h, and
	   the tree for the rest r is copied as many times as there
	   are strings in h (and we add one node for the blank
	   separating name components). *)
  | [] -> failwith "this cannot happen"
;;


(* return the list of abbreviations of a name and the pathlength  *)
let abbreviate name =
  let parts = (split (regexp "[ \t\n]+")
		 (global_replace (regexp "==") "=" name))
  in
    if List.length parts = 1
    then ( parts , String.length (List.hd parts) )
    else
      let elist = expand_namelist parts
      in ( allproducts " " elist , pathlength elist )
;;

