Uzurka/Geneweb
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
master
Geneweb/lib/some.ml
Uzurka 385cf8e5aa Initial comit - Clone
2024-03-05 22:01:20 +01:00

883 lines
30 KiB
OCaml
Raw Permalink Blame History

(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Gwdb
open Util
module StrSet = Mutil.StrSet
let not_found conf txt x =
let title _ =
Output.print_sstring conf (Utf8.capitalize_fst txt);
Output.print_sstring conf (transl conf ":");
Output.print_sstring conf {| "|};
Output.print_string conf (Util.escape_html x);
Output.print_sstring conf {|"|}
in
Hutil.rheader conf title;
Hutil.print_link_to_welcome conf false;
Hutil.trailer conf
let first_name_not_found conf =
not_found conf (transl conf "first name not found")
let surname_not_found conf = not_found conf (transl conf "surname not found")
let print_img conf img =
Output.print_sstring conf {|<img src="|};
Output.print_sstring conf (Util.images_prefix conf);
Output.print_sstring conf {|/|};
Output.print_string conf img;
Output.print_sstring conf {|" alt="" title="">|}
(* **********************************************************************)
(* [Fonc] print_branch_to_alphabetic : conf -> string -> int -> unit *)
(* ******************************************************************** *)
(** [Description] : A partir de l'affichage par branches, permet
d'afficher les liens pour un affichage par ordre
alphabétique.
[Args] :
- conf : configuration de la base
- base : base
- x : 'nom/prénom/sosa...' recherché
- nb_branch : nombre de branches dans le résultat de la recherche
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let print_branch_to_alphabetic conf x nb_branch =
Output.print_sstring conf {|<table class="display_search"><tr><td><b>|};
Output.print_sstring conf
(Utf8.capitalize_fst
(transl_nth conf "display by/branch/alphabetic order" 0));
Output.print_sstring conf {|</b></td><td>|};
print_img conf (Adef.encoded "picto_branch.png");
Output.print_sstring conf {|</td><td>|};
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 1);
Output.print_sstring conf " (";
Output.print_sstring conf (string_of_int nb_branch);
Output.print_sstring conf {|)</td><td>|};
print_img conf (Adef.encoded "picto_alphabetic_order.png");
Output.print_sstring conf {|</td><td>|};
(* Ne pas oublier l'attribut nofollow pour les robots *)
if p_getenv conf.env "t" = Some "A" then (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=N&o=i&t=A&v=";
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 2);
Output.print_sstring conf "</a>")
else (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=N&o=i&t=N&v=|};
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 2);
Output.print_sstring conf "</a>");
(* Ne pas oublier l'attribut nofollow pour les robots *)
Output.print_sstring conf "</td></tr></table><br>"
(* **********************************************************************)
(* [Fonc] print_alphabetic_to_branch : conf -> string -> int -> unit *)
(* ******************************************************************** *)
(** [Description] : A partir de l'affichage alphabétique, permet
d'afficher les liens pour un affichage par branches.
[Args] :
- conf : configuration de la base
- base : base
- x : 'nom/prénom/sosa...' recherché
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
let print_alphabetic_to_branch conf x =
Output.print_sstring conf {|<table class="display_search"><tr><td><b>|};
Output.print_sstring conf
(Utf8.capitalize_fst
(transl_nth conf "display by/branch/alphabetic order" 0));
Output.print_sstring conf "</b></td><td>";
print_img conf (Adef.encoded "picto_branch.png");
Output.print_sstring conf "</td><td>";
if p_getenv conf.env "t" = Some "A" then (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=N&t=A&v=";
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 1);
Output.print_sstring conf "</a>")
else (
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf "m=NG&sn=";
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 1);
Output.print_sstring conf "</a>");
Output.print_sstring conf "</td><td>";
print_img conf (Adef.encoded "picto_alphabetic_order.png");
Output.print_sstring conf "</td><td>";
Output.print_sstring conf
(transl_nth conf "display by/branch/alphabetic order" 2);
Output.print_sstring conf "</td></tr></table><br>"
let persons_of_fsname conf base base_strings_of_fsname find proj x =
(* list of strings index corresponding to the crushed lower first name
or surname "x" *)
let istrl = base_strings_of_fsname base x in
(* selecting the persons who have this first name or surname *)
let l =
let x = Name.crush_lower x in
List.fold_right
(fun istr l ->
let str = Mutil.nominative (sou base istr) in
if
Name.crush_lower str = x
|| List.mem x (List.map Name.crush_lower (Mutil.surnames_pieces str))
then
let iperl = find istr in
(* maybe they are not the good ones because of changes in the
database; checking... *)
let iperl =
List.fold_left
(fun iperl iper ->
if eq_istr (proj (pget conf base iper)) istr then iper :: iperl
else iperl)
[] iperl
in
if iperl = [] then l else (str, istr, iperl) :: l
else l)
istrl []
in
let l, name_inj =
let l1, name_inj =
let x = Name.lower x in
( List.fold_right
(fun (str, istr, iperl) l ->
if x = Name.lower str then (str, istr, iperl) :: l else l)
l [],
Name.lower )
in
let l1, name_inj =
if l1 = [] then
let x = Name.strip_lower x in
( List.fold_right
(fun (str, istr, iperl) l ->
if x = Name.strip_lower str then (str, istr, iperl) :: l else l)
l [],
Name.strip_lower )
else (l1, name_inj)
in
if l1 = [] then (l, Name.crush_lower) else (l1, name_inj)
in
(l, name_inj)
let print_elem conf base is_surname (p, xl) =
Mutil.list_iter_first
(fun first x ->
let iper = get_iper x in
if not first then Output.print_sstring conf "</li><li> ";
SosaCache.print_sosa conf base x true;
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_string conf (acces conf base x);
Output.print_sstring conf {|" id="i|};
Output.print_sstring conf (string_of_iper iper);
Output.print_sstring conf {|">|};
if is_surname then (
Output.print_string conf (escape_html @@ surname_without_particle base p);
Output.print_string conf (escape_html @@ surname_particle base p))
else
Output.print_string conf
(if p = "" then Adef.escaped "?" else escape_html p);
Output.print_sstring conf "</a>";
Output.print_string conf (DateDisplay.short_dates_text conf base x);
Output.print_sstring conf "<em>";
specify_homonymous conf base x true;
Output.print_sstring conf "</em>")
xl
let first_char s =
(* Si la personne n'a pas de prénom/nom, on renvoie '?' *)
if s = "" then "?"
else
let len = Utf8.next s 0 in
if len < String.length s then String.sub s 0 len else s
let name_unaccent s =
let rec copy i len =
if i = String.length s then Buff.get len
else
let t, j = Name.unaccent_utf_8 false s i in
copy j (Buff.mstore len t)
in
copy 0 0
let first_name_print_list conf base x1 xl liste =
let liste =
let l =
List.sort
(fun x1 x2 ->
match Gutil.alphabetic (p_surname base x1) (p_surname base x2) with
| 0 -> (
match
( Date.od_of_cdate (get_birth x1),
Date.od_of_cdate (get_birth x2) )
with
| Some d1, Some d2 -> Date.compare_date d1 d2
| Some _, _ -> 1
| _ -> -1)
| n -> -n)
liste
in
List.fold_left
(fun l x ->
let px = p_surname base x in
match l with
| (p, l1) :: l when Gutil.alphabetic px p = 0 -> (p, x :: l1) :: l
| _ -> (px, [ x ]) :: l)
[] l
in
let title h =
if h || p_getenv conf.env "t" = Some "A" then
Output.print_string conf (escape_html x1)
else
Mutil.list_iter_first
(fun first x ->
if not first then Output.print_sstring conf ", ";
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=P&t=A&v=|};
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|">|};
Output.print_string conf (escape_html x);
Output.print_sstring conf {|</a>|})
(StrSet.elements xl)
in
Hutil.header conf title;
(* Si on est dans un calcul de parent<6E>, on affiche *)
(* l'aide sur la s<>lection d'un individu. *)
Util.print_tips_relationship conf;
let list =
List.map
(fun (sn, ipl) ->
let txt =
Util.surname_without_particle base sn ^ Util.surname_particle base sn
in
let ord = name_unaccent txt in
(ord, txt, ipl))
liste
in
let list = List.sort compare list in
print_alphab_list conf
(fun (ord, _, _) -> first_char ord)
(fun (_, txt, ipl) -> print_elem conf base true (txt, ipl))
list;
Hutil.trailer conf
let mk_specify_title conf kw n _ =
Output.print_sstring conf (Utf8.capitalize_fst kw);
Output.print_sstring conf {| "|};
Output.print_string conf (escape_html n);
Output.print_sstring conf {|"|};
Output.print_sstring conf (transl conf ":");
Output.print_sstring conf {| |};
Output.print_sstring conf (transl conf "specify")
let select_first_name conf n list =
Hutil.header conf
@@ mk_specify_title conf (transl_nth conf "first name/first names" 0) n;
Output.print_sstring conf "<ul>";
List.iter
(fun (sstr, (strl, _)) ->
Output.print_sstring conf {|<li><a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=P&v=|};
Output.print_string conf (Mutil.encode sstr);
Output.print_sstring conf {|">|};
Mutil.list_iter_first
(fun first str ->
if not first then Output.print_sstring conf ", ";
Output.print_string conf (escape_html str))
(StrSet.elements strl);
Output.print_sstring conf "</a>\n")
list;
Output.print_sstring conf "</ul>\n";
Hutil.trailer conf
let rec merge_insert ((sstr, (strl, iperl)) as x) = function
| ((sstr1, (strl1, iperl1)) as y) :: l ->
if sstr < sstr1 then x :: y :: l
else if sstr > sstr1 then y :: merge_insert x l
else (sstr, (StrSet.union strl strl1, iperl @ iperl1)) :: l
| [] -> [ x ]
let persons_of_absolute base_strings_of persons_of get_field conf base x =
let istrl = base_strings_of base x in
List.fold_right
(fun istr l ->
let str = sou base istr in
if str = x then
let iperl = spi_find (persons_of base) istr in
let iperl =
List.fold_left
(fun iperl iper ->
let p = pget conf base iper in
if
eq_istr (get_field p) istr
&& ((not (is_hide_names conf p))
|| Util.authorized_age conf base p)
then iper :: iperl
else iperl)
[] iperl
in
if iperl = [] then l else (str, istr, iperl) :: l
else l)
istrl []
let persons_of_absolute_first_name =
persons_of_absolute base_strings_of_first_name persons_of_first_name
get_first_name
let persons_of_absolute_surname =
persons_of_absolute base_strings_of_surname persons_of_surname get_surname
let has_children_with_that_name conf base des name =
let compare_name n1 n2 =
if p_getenv conf.env "t" = Some "A" then n1 = n2
else Name.lower n1 = Name.lower n2
in
List.exists
(fun ip -> compare_name (p_surname base (pget conf base ip)) name)
(Array.to_list (get_children des))
(* List selection bullets *)
let bullet_sel_txt = Adef.safe "o"
let bullet_unsel_txt = Adef.safe "+"
let bullet_nosel_txt = Adef.safe "o"
let print_selection_bullet conf = function
| Some (txt, sel) ->
let req : Adef.encoded_string =
List.fold_left
(fun (req : Adef.encoded_string) (k, (v : Adef.encoded_string)) ->
if (not sel) && k = "u" && v = txt then req
else
let s : Adef.encoded_string = Adef.encoded k ^^^ "=" ^<^ v in
if (req :> string) = "" then s else req ^^^ "&" ^<^ s)
(Adef.encoded "") conf.env
in
Output.print_sstring conf {|<a id="if|};
Output.print_string conf txt;
Output.print_sstring conf {|" href="|};
Output.print_string conf (prefix_base conf);
Output.print_string conf req;
if sel then Output.print_string conf ("&u=" ^<^ txt);
if sel || List.mem_assoc "u" conf.env then
Output.print_string conf ("#if" ^<^ txt);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_string conf
(if sel then bullet_sel_txt else bullet_unsel_txt);
Output.print_sstring conf "</a>\n"
| None ->
Output.print_string conf bullet_nosel_txt;
Output.print_sstring conf "\n"
let unselected_bullets conf =
List.fold_left
(fun sl (k, v) ->
try if k = "u" then ifam_of_string (Mutil.decode v) :: sl else sl
with Failure _ -> sl)
[] conf.env
let alphabetic1 n1 n2 = Gutil.alphabetic_utf_8 n1 n2
type 'a branch_head = { bh_ancestor : 'a; bh_well_named_ancestors : 'a list }
let print_branch conf base psn name =
let unsel_list = unselected_bullets conf in
let rec loop p =
let u = pget conf base (get_iper p) in
let family_list =
Array.map
(fun ifam ->
let fam = foi base ifam in
let c = Gutil.spouse (get_iper p) fam in
let c = pget conf base c in
let down = has_children_with_that_name conf base fam name in
let down =
if get_sex p = Female && p_surname base c = name then false
else down
in
let i = ifam in
let sel = not (List.mem i unsel_list) in
( fam,
c,
if down then Some (Mutil.encode @@ string_of_ifam i, sel) else None
))
(get_family u)
in
let first_select =
if family_list = [||] then None
else (fun (_, _, s) -> s) (Array.unsafe_get family_list 0)
in
let print_elem p with_link with_id with_sn =
let render p =
if with_link then
if with_id then Util.reference conf base p
else Util.reference_noid conf base p
else fun s -> s
in
SosaCache.print_sosa conf base p with_link;
Output.print_sstring conf @@ if with_link then "<strong>" else "<em>";
Output.print_string conf
(render p
(if is_hide_names conf p && not (authorized_age conf base p) then
Adef.safe "x"
else if (not psn) && (not with_sn) && p_surname base p = name then
gen_person_text ~sn:false conf base p
else gen_person_text conf base p));
Output.print_sstring conf @@ if with_link then "</strong>" else "</em>";
Output.print_string conf (DateDisplay.short_dates_text conf base p);
Output.print_sstring conf "\n"
in
Output.print_sstring conf "<li>";
print_selection_bullet conf first_select;
print_elem p true true false;
if Array.length (get_family u) <> 0 then
ignore
@@ Array.fold_left
(fun first (fam, sp, select) ->
if not first then (
Output.print_sstring conf "<li>";
print_selection_bullet conf select;
print_elem p false true false);
Output.print_sstring conf " &amp;";
Output.print_string conf
(DateDisplay.short_marriage_date_text conf base fam p sp);
Output.print_sstring conf "\n";
print_elem sp true false true;
let children = get_children fam in
(match select with
| Some (_, true) ->
Output.print_sstring conf "<ul>";
Array.iter
(fun e ->
loop (pget conf base e);
Output.print_sstring conf "</li>")
children;
Output.print_sstring conf "</ul>"
| Some (_, false) -> ()
| None ->
if Array.length children <> 0 then
Output.print_sstring conf
{|<ul class="posterity"><li>...</li></ul>|});
Output.print_sstring conf "</li>";
false)
true family_list;
Output.print_sstring conf "</li>"
in
loop
let print_one_branch conf base bh psn =
Output.print_sstring conf "<ul>";
let p = bh.bh_ancestor in
if bh.bh_well_named_ancestors = [] then
let x = sou base (get_surname p) in
print_branch conf base psn x p
else (
Output.print_sstring conf "<li>";
if is_hidden p then Output.print_sstring conf "&lt;&lt;"
else
wprint_geneweb_link conf (Util.acces conf base p) (Adef.safe "&lt;&lt;");
Output.print_sstring conf "<ul>";
List.iter
(fun p ->
let x = sou base (get_surname p) in
print_branch conf base psn x p)
bh.bh_well_named_ancestors;
Output.print_sstring conf "</ul></li>");
Output.print_sstring conf "</ul>"
let print_one_surname_by_branch conf base x xl (bhl, str) =
let ancestors =
match p_getenv conf.env "order" with
| Some "d" ->
let born_before p1 p2 =
match
(Date.od_of_cdate (get_birth p1), Date.od_of_cdate (get_birth p2))
with
| Some d1, Some d2 -> Date.compare_date d1 d2
| _, None -> -1
| None, _ -> 1
in
List.sort (fun p1 p2 -> born_before p1.bh_ancestor p2.bh_ancestor) bhl
| _ ->
List.sort
(fun p1 p2 ->
alphabetic1
(p_first_name base p1.bh_ancestor)
(p_first_name base p2.bh_ancestor))
bhl
in
let len = List.length ancestors in
let psn =
match p_getenv conf.env "alwsurn" with
| Some x -> x = "yes"
| None -> (
try List.assoc "always_surname" conf.base_env = "yes"
with Not_found -> false)
in
let title h =
if h || p_getenv conf.env "t" = Some "A" then
Output.print_string conf (escape_html x)
else
Mutil.list_iter_first
(fun first x ->
if not first then Output.print_sstring conf ", ";
Output.print_sstring conf {|<a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=N&t=A&v=|};
Output.print_string conf (Mutil.encode x);
Output.print_sstring conf {|">|};
Output.print_string conf (escape_html x);
Output.print_sstring conf {|</a>|})
(StrSet.elements xl)
in
let br = p_getint conf.env "br" in
Hutil.header conf title;
(* Si on est dans un calcul de parenté, on affiche *)
(* l'aide sur la sélection d'un individu. *)
Util.print_tips_relationship conf;
(* Menu afficher par branche/ordre alphabetique *)
if br = None then print_branch_to_alphabetic conf x len;
Output.print_sstring conf {|<div id="surname_by_branch">|};
if len > 1 && br = None then (
Output.print_sstring conf "<dl>";
ignore
@@ List.fold_left
(fun n bh ->
Output.print_sstring conf {|<dt><a href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=N&v=|};
Output.print_string conf (Mutil.encode str);
Output.print_sstring conf {|&br=|};
Output.print_sstring conf (string_of_int n);
Output.print_sstring conf {|" rel="nofollow">|};
Output.print_sstring conf (string_of_int n);
Output.print_sstring conf ".</a></dt><dd>";
print_one_branch conf base bh psn;
Output.print_sstring conf "</dd>";
n + 1)
1 ancestors;
Output.print_sstring conf "</dl>")
else
ignore
@@ List.fold_left
(fun n bh ->
if br = None || br = Some n then print_one_branch conf base bh psn;
n + 1)
1 ancestors;
Output.print_sstring conf "</div>";
Hutil.trailer conf
let print_several_possible_surnames x conf base (_, homonymes) =
let fx = x in
let x = match homonymes with x :: _ -> x | _ -> x in
let title = mk_specify_title conf (transl_nth conf "surname/surnames" 0) fx in
Hutil.header conf title;
let list =
List.map
(fun sn ->
let txt =
Util.surname_without_particle base sn ^ Util.surname_particle base sn
in
let ord = name_unaccent txt in
(ord, txt, sn))
homonymes
in
let list = List.sort compare list in
let access txt sn =
geneweb_link conf
("m=N&v=" ^<^ Mutil.encode sn ^>^ "&t=N" :> Adef.escaped_string)
(escape_html txt :> Adef.safe_string)
in
Util.wprint_in_columns conf
(fun (ord, _, _) -> ord)
(fun (_, txt, sn) -> Output.print_string conf (access txt sn))
list;
Output.print_sstring conf {|<p><em style="font-size:80%">|};
Output.print_sstring conf {| <a |};
Output.print_sstring conf {| href="|};
Output.print_string conf (commd conf);
Output.print_sstring conf {|m=N&o=i&t=N&v=|};
Output.print_string conf
(if List.length homonymes = 1 then Mutil.encode x else Mutil.encode fx);
Output.print_sstring conf {|">|};
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "click"));
Output.print_sstring conf " ";
Output.print_sstring conf (transl conf "here");
Output.print_sstring conf " ";
Output.print_sstring conf
(transl conf "for the first names by alphabetic order");
Output.print_sstring conf {|</a> |};
Output.print_sstring conf ".</em></p>";
Hutil.trailer conf
let print_family_alphabetic x conf base liste =
let homonymes =
let list =
List.fold_left
(fun list p ->
if List.exists (eq_istr (get_surname p)) list then list
else get_surname p :: list)
[] liste
in
let set =
List.fold_left
(fun set istr -> StrSet.add (sou base istr) set)
StrSet.empty list
in
List.sort compare (StrSet.elements set)
in
let liste =
let l =
List.sort
(fun x1 x2 ->
match alphabetic1 (p_first_name base x2) (p_first_name base x1) with
| 0 -> compare (get_occ x1) (get_occ x2)
| n -> n)
liste
in
List.fold_left
(fun l x ->
let px = p_first_name base x in
match l with
| (p, l1) :: l when alphabetic1 px p = 0 -> (p, x :: l1) :: l
| _ -> (px, [ x ]) :: l)
[] l
in
match liste with
| [] -> surname_not_found conf x
| _ ->
let title h =
let access x =
if h || List.length homonymes = 1 then
(Util.escape_html x :> Adef.safe_string)
else
geneweb_link conf
("m=N&o=i&v=" ^<^ Mutil.encode x ^>^ "&t=A"
:> Adef.escaped_string)
(escape_html x :> Adef.safe_string)
in
Mutil.list_iter_first
(fun first x ->
if not first then Output.print_sstring conf ", ";
Output.print_string conf (access x))
homonymes
in
Hutil.header conf title;
(* Si on est dans un calcul de parent<6E>, on affiche *)
(* l'aide sur la s<>lection d'un individu. *)
Util.print_tips_relationship conf;
(* Menu afficher par branche/ordre alphabetique *)
print_alphabetic_to_branch conf x;
print_alphab_list conf
(fun (p, _) -> first_char p)
(print_elem conf base false)
liste;
Hutil.trailer conf
let insert_at_position_in_family children ip ipl =
let rec loop child_list ipl =
match (child_list, ipl) with
| ip1 :: ipl1, ip2 :: ipl2 ->
if ip1 = ip2 then if ip = ip1 then ipl else ip2 :: loop ipl1 ipl2
else if ip = ip1 then ip1 :: ipl
else loop ipl1 ipl
| _ :: _, [] -> [ ip ]
| [], _ -> assert false
in
loop (Array.to_list children) ipl
let select_ancestors conf base name_inj ipl =
let str_inj s = name_inj (sou base s) in
List.fold_left
(fun bhl ip ->
let p = pget conf base ip in
match get_parents p with
| Some ifam ->
let fam = foi base ifam in
let ifath = get_father fam in
let imoth = get_mother fam in
let fath = pget conf base ifath in
let moth = pget conf base imoth in
let s = str_inj (get_surname p) in
if str_inj (get_surname fath) <> s && str_inj (get_surname moth) <> s
then
let rec loop = function
| bh :: bhl ->
if bh.bh_ancestor = ifath || bh.bh_ancestor = imoth then
let bh =
{
bh with
bh_well_named_ancestors =
insert_at_position_in_family (get_children fam) ip
bh.bh_well_named_ancestors;
}
in
bh :: bhl
else bh :: loop bhl
| [] ->
[ { bh_ancestor = ifath; bh_well_named_ancestors = [ ip ] } ]
in
loop bhl
else bhl
| _ ->
let bh = { bh_ancestor = ip; bh_well_named_ancestors = [] } in
bh :: bhl)
[] ipl
module PerSet = Set.Make (struct
type t = iper
let compare = compare
end)
let search_surname_list conf base x =
let list, name_inj =
if p_getenv conf.env "t" = Some "A" then
(persons_of_absolute_surname conf base x, fun x -> x)
else if x = "" then
([], fun _ -> raise (Match_failure ("src/some.ml", 942, 29)))
else
persons_of_fsname conf base base_strings_of_surname
(spi_find (persons_of_surname base))
get_surname x
in
let list =
List.map
(fun (str, _, iperl) ->
(Name.lower str, (StrSet.add str StrSet.empty, iperl)))
list
in
let list = List.fold_right merge_insert list [] in
let iperl, _ =
List.fold_right
(fun (str, (_, iperl1)) (iperl, strl) ->
let len = List.length iperl1 in
let strl =
try
let len1 = List.assoc str strl in
(str, len + len1) :: List.remove_assoc str strl
with Not_found -> (str, len) :: strl
in
(List.fold_right PerSet.add iperl1 iperl, strl))
list (PerSet.empty, [])
in
(list, PerSet.elements iperl, name_inj)
let search_surname conf base x =
let list, iperl, name_inj = search_surname_list conf base x in
let bhl = select_ancestors conf base name_inj iperl in
let bhl =
List.map
(fun bh ->
{
bh_ancestor = pget conf base bh.bh_ancestor;
bh_well_named_ancestors =
List.map (pget conf base) bh.bh_well_named_ancestors;
})
bhl
in
match (bhl, list) with
| [], _ -> []
| _, [ (_, (_, iperl)) ] -> iperl
| _ -> []
let search_surname_print conf base not_found_fun x =
let list, iperl, name_inj = search_surname_list conf base x in
(* Construction de la table des sosa de la base *)
let () = SosaCache.build_sosa_ht conf base in
match p_getenv conf.env "o" with
| Some "i" ->
let pl =
List.fold_right (fun ip ipl -> pget conf base ip :: ipl) iperl []
in
let pl =
List.fold_right
(fun p pl ->
if (not (is_hide_names conf p)) || authorized_age conf base p then
p :: pl
else pl)
pl []
in
print_family_alphabetic x conf base pl
| _ -> (
let bhl = select_ancestors conf base name_inj iperl in
let bhl =
List.map
(fun bh ->
{
bh_ancestor = pget conf base bh.bh_ancestor;
bh_well_named_ancestors =
List.map (pget conf base) bh.bh_well_named_ancestors;
})
bhl
in
match (bhl, list) with
| [], _ -> not_found_fun conf x
| _, [ (s, (strl, _)) ] ->
print_one_surname_by_branch conf base x strl (bhl, s)
| _ ->
let strl = List.map (fun (s, _) -> s) list in
print_several_possible_surnames x conf base (bhl, strl))
let search_first_name conf base x =
let list, _ =
if p_getenv conf.env "t" = Some "A" then
( persons_of_absolute_first_name conf base x,
fun _ -> raise (Match_failure ("src/some.ml", 1007, 51)) )
else if x = "" then
([], fun _ -> raise (Match_failure ("src/some.ml", 1008, 29)))
else
persons_of_fsname conf base base_strings_of_first_name
(spi_find (persons_of_first_name base))
get_first_name x
in
let list =
List.map
(fun (str, _, iperl) ->
(Name.lower str, (StrSet.add str StrSet.empty, iperl)))
list
in
List.fold_right merge_insert list []
let search_first_name_print conf base x =
let list = search_first_name conf base x in
(* Construction de la table des sosa de la base *)
let () = SosaCache.build_sosa_ht conf base in
match list with
| [] -> first_name_not_found conf x
| [ (_, (strl, iperl)) ] ->
let iperl = List.sort_uniq compare iperl in
let pl = List.map (pget conf base) iperl in
let pl =
List.fold_right
(fun p pl ->
if (not (is_hide_names conf p)) || authorized_age conf base p then
p :: pl
else pl)
pl []
in
first_name_print_list conf base x strl pl
| _ -> select_first_name conf x list
Reference in New Issue View Git Blame Copy Permalink