296 lines
9.5 KiB
OCaml
296 lines
9.5 KiB
OCaml
(* Copyright (c) 2006-2007 INRIA *)
|
|
|
|
open Adef
|
|
open Def
|
|
|
|
external identity : 'a -> 'a = "%identity"
|
|
|
|
let map_cdate fd d =
|
|
match Date.od_of_cdate d with
|
|
| Some d -> Date.cdate_of_date (fd d)
|
|
| None -> d
|
|
|
|
let map_title_strings ?(fd = identity) f t =
|
|
let t_name =
|
|
match t.t_name with
|
|
| Tmain -> Tmain
|
|
| Tname s -> Tname (f s)
|
|
| Tnone -> Tnone
|
|
in
|
|
let t_ident = f t.t_ident in
|
|
let t_place = f t.t_place in
|
|
{
|
|
t_name;
|
|
t_ident;
|
|
t_place;
|
|
t_date_start = map_cdate fd t.t_date_start;
|
|
t_date_end = map_cdate fd t.t_date_end;
|
|
t_nth = t.t_nth;
|
|
}
|
|
|
|
let map_pers_event ?(fd = identity) fp fs e =
|
|
let epers_name =
|
|
match e.epers_name with
|
|
| ( Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial
|
|
| Epers_Cremation | Epers_Accomplishment | Epers_Acquisition
|
|
| Epers_Adhesion | Epers_BaptismLDS | Epers_BarMitzvah | Epers_BatMitzvah
|
|
| Epers_Benediction | Epers_ChangeName | Epers_Circumcision
|
|
| Epers_Confirmation | Epers_ConfirmationLDS | Epers_Decoration
|
|
| Epers_DemobilisationMilitaire | Epers_Diploma | Epers_Distinction
|
|
| Epers_Dotation | Epers_DotationLDS | Epers_Education | Epers_Election
|
|
| Epers_Emigration | Epers_Excommunication | Epers_FamilyLinkLDS
|
|
| Epers_FirstCommunion | Epers_Funeral | Epers_Graduate
|
|
| Epers_Hospitalisation | Epers_Illness | Epers_Immigration
|
|
| Epers_ListePassenger | Epers_MilitaryDistinction
|
|
| Epers_MilitaryPromotion | Epers_MilitaryService
|
|
| Epers_MobilisationMilitaire | Epers_Naturalisation | Epers_Occupation
|
|
| Epers_Ordination | Epers_Property | Epers_Recensement | Epers_Residence
|
|
| Epers_Retired | Epers_ScellentChildLDS | Epers_ScellentParentLDS
|
|
| Epers_ScellentSpouseLDS | Epers_VenteBien | Epers_Will ) as evt ->
|
|
evt
|
|
| Epers_Name s -> Epers_Name (fs s)
|
|
in
|
|
let epers_date = map_cdate fd e.epers_date in
|
|
let epers_place = fs e.epers_place in
|
|
let epers_reason = fs e.epers_reason in
|
|
let epers_note = fs e.epers_note in
|
|
let epers_src = fs e.epers_src in
|
|
let epers_witnesses = Array.map (fun (p, w) -> (fp p, w)) e.epers_witnesses in
|
|
{
|
|
epers_name;
|
|
epers_date;
|
|
epers_place;
|
|
epers_reason;
|
|
epers_note;
|
|
epers_src;
|
|
epers_witnesses;
|
|
}
|
|
|
|
let map_fam_event ?(fd = identity) fp fs e =
|
|
let efam_name =
|
|
match e.efam_name with
|
|
| ( Efam_Marriage | Efam_NoMarriage | Efam_NoMention | Efam_Engage
|
|
| Efam_Divorce | Efam_Separated | Efam_Annulation | Efam_MarriageBann
|
|
| Efam_MarriageContract | Efam_MarriageLicense | Efam_PACS
|
|
| Efam_Residence ) as evt ->
|
|
evt
|
|
| Efam_Name s -> Efam_Name (fs s)
|
|
in
|
|
let efam_date = map_cdate fd e.efam_date in
|
|
let efam_place = fs e.efam_place in
|
|
let efam_reason = fs e.efam_reason in
|
|
let efam_note = fs e.efam_note in
|
|
let efam_src = fs e.efam_src in
|
|
let efam_witnesses = Array.map (fun (p, w) -> (fp p, w)) e.efam_witnesses in
|
|
{
|
|
efam_name;
|
|
efam_date;
|
|
efam_place;
|
|
efam_reason;
|
|
efam_note;
|
|
efam_src;
|
|
efam_witnesses;
|
|
}
|
|
|
|
let map_relation_ps fp fs r =
|
|
{
|
|
r_type = r.r_type;
|
|
r_fath = (match r.r_fath with Some x -> Some (fp x) | None -> None);
|
|
r_moth = (match r.r_moth with Some x -> Some (fp x) | None -> None);
|
|
r_sources = fs r.r_sources;
|
|
}
|
|
|
|
let map_death fd = function
|
|
| (NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead | OfCourseDead) as
|
|
x ->
|
|
x
|
|
| Death (r, d) -> Death (r, map_cdate fd d)
|
|
|
|
let map_burial fd = function
|
|
| UnknownBurial -> UnknownBurial
|
|
| Buried d -> Buried (map_cdate fd d)
|
|
| Cremated d -> Cremated (map_cdate fd d)
|
|
|
|
let map_person_ps ?(fd = identity) fp fs p =
|
|
{
|
|
first_name = fs p.first_name;
|
|
surname = fs p.surname;
|
|
occ = p.occ;
|
|
image = fs p.image;
|
|
first_names_aliases = List.map fs p.first_names_aliases;
|
|
surnames_aliases = List.map fs p.surnames_aliases;
|
|
public_name = fs p.public_name;
|
|
qualifiers = List.map fs p.qualifiers;
|
|
titles = List.map (map_title_strings ~fd fs) p.titles;
|
|
rparents = List.map (map_relation_ps fp fs) p.rparents;
|
|
related = List.map fp p.related;
|
|
aliases = List.map fs p.aliases;
|
|
occupation = fs p.occupation;
|
|
sex = p.sex;
|
|
access = p.access;
|
|
birth = map_cdate fd p.birth;
|
|
birth_place = fs p.birth_place;
|
|
birth_note = fs p.birth_note;
|
|
birth_src = fs p.birth_src;
|
|
baptism = map_cdate fd p.baptism;
|
|
baptism_place = fs p.baptism_place;
|
|
baptism_note = fs p.baptism_note;
|
|
baptism_src = fs p.baptism_src;
|
|
death = map_death fd p.death;
|
|
death_place = fs p.death_place;
|
|
death_note = fs p.death_note;
|
|
death_src = fs p.death_src;
|
|
burial = map_burial fd p.burial;
|
|
burial_place = fs p.burial_place;
|
|
burial_note = fs p.burial_note;
|
|
burial_src = fs p.burial_src;
|
|
pevents = List.map (map_pers_event ~fd fp fs) p.pevents;
|
|
notes = fs p.notes;
|
|
psources = fs p.psources;
|
|
key_index = p.key_index;
|
|
}
|
|
|
|
let map_ascend_f ff a =
|
|
match a.parents with
|
|
| Some f -> { parents = Some (ff f); consang = a.consang }
|
|
| None -> { parents = None; consang = a.consang }
|
|
|
|
let map_union_f ff u = { family = Array.map ff u.family }
|
|
|
|
let map_divorce fd = function
|
|
| (NotDivorced | Separated) as x -> x
|
|
| Divorced d -> Divorced (map_cdate fd d)
|
|
|
|
let map_family_ps ?(fd = identity) fp ff fs fam =
|
|
{
|
|
marriage = map_cdate fd fam.marriage;
|
|
marriage_place = fs fam.marriage_place;
|
|
marriage_note = fs fam.marriage_note;
|
|
marriage_src = fs fam.marriage_src;
|
|
witnesses = Array.map fp fam.witnesses;
|
|
relation = fam.relation;
|
|
divorce = map_divorce fd fam.divorce;
|
|
fevents = List.map (map_fam_event ~fd fp fs) fam.fevents;
|
|
comment = fs fam.comment;
|
|
origin_file = fs fam.origin_file;
|
|
fsources = fs fam.fsources;
|
|
fam_index = ff fam.fam_index;
|
|
}
|
|
|
|
let parent multi parent =
|
|
if not multi then Adef.parent parent else Adef.multi_parent parent
|
|
|
|
let map_couple_p multi_parents fp cpl =
|
|
parent multi_parents (Array.map fp (parent_array cpl))
|
|
|
|
let map_descend_p fp des = { children = Array.map fp des.children }
|
|
|
|
let gen_person_misc_names sou empty_string quest_string first_name surname
|
|
public_name qualifiers aliases first_names_aliases surnames_aliases titles
|
|
husbands father_titles_places =
|
|
if first_name = quest_string || surname = quest_string then []
|
|
else
|
|
let s_first_name = Mutil.nominative @@ sou first_name in
|
|
let s_surname = Mutil.nominative @@ sou surname in
|
|
let s_titles_names =
|
|
List.fold_left
|
|
(fun acc t ->
|
|
match t.t_name with Tmain | Tnone -> acc | Tname x -> sou x :: acc)
|
|
[] titles
|
|
in
|
|
let s_public_names =
|
|
if public_name = empty_string then s_titles_names
|
|
else sou public_name :: s_titles_names
|
|
in
|
|
let s_first_names =
|
|
s_first_name
|
|
:: (* List.rev_append *)
|
|
List.rev_map sou first_names_aliases (* public_names *)
|
|
in
|
|
let s_surnames =
|
|
s_surname
|
|
:: Mutil.list_rev_map_append sou surnames_aliases
|
|
(Mutil.list_rev_map_append sou qualifiers
|
|
@@ Mutil.surnames_pieces s_surname)
|
|
in
|
|
let s_surnames =
|
|
Array.fold_left
|
|
(fun s_list (husband_surname, husband_surnames_aliases) ->
|
|
if husband_surname = quest_string then
|
|
Mutil.list_rev_map_append sou husband_surnames_aliases s_list
|
|
else
|
|
let s_husband_surname = Mutil.nominative @@ sou husband_surname in
|
|
s_husband_surname
|
|
:: Mutil.list_rev_map_append sou husband_surnames_aliases
|
|
(List.rev_append
|
|
(Mutil.surnames_pieces s_husband_surname)
|
|
s_list))
|
|
s_surnames husbands
|
|
in
|
|
(* (public names) *)
|
|
let s_list = s_public_names in
|
|
(* + (first names) x (surnames) *)
|
|
let s_list =
|
|
List.fold_left
|
|
(fun list f ->
|
|
List.fold_left (fun list s -> Name.concat f s :: list) list s_surnames)
|
|
s_list s_first_names
|
|
in
|
|
(* + (first names + (title | (public name)) ) x (titles places) *)
|
|
let s_list =
|
|
(* let first_names = first_name :: first_names_aliases in *)
|
|
List.fold_left
|
|
(fun list t ->
|
|
let s = t.t_place in
|
|
if s = empty_string then list
|
|
else
|
|
let s = sou s in
|
|
let s_first_names =
|
|
match t.t_name with
|
|
| Tname f -> sou f :: s_first_names
|
|
| Tmain | Tnone ->
|
|
if public_name = empty_string then s_first_names
|
|
else sou public_name :: s_first_names
|
|
in
|
|
List.fold_left
|
|
(fun list f -> Name.concat f s :: list)
|
|
list s_first_names)
|
|
s_list titles
|
|
in
|
|
(* + (first names) x (father's title places) *)
|
|
let list =
|
|
if father_titles_places = [] then s_list
|
|
else
|
|
List.fold_left
|
|
(fun list t ->
|
|
let s = t.t_place in
|
|
if s = empty_string then list
|
|
else
|
|
let s = sou s in
|
|
List.fold_left
|
|
(fun list f -> Name.concat f s :: list)
|
|
list s_first_names)
|
|
s_list father_titles_places
|
|
in
|
|
let list = Mutil.list_rev_map_append sou aliases list in
|
|
list
|
|
|
|
let rec eq_lists eq l1 l2 =
|
|
match (l1, l2) with
|
|
| x1 :: l1, x2 :: l2 -> eq x1 x2 && eq_lists eq l1 l2
|
|
| [], [] -> true
|
|
| _ -> false
|
|
|
|
let eq_title_names eq tn1 tn2 =
|
|
match (tn1, tn2) with
|
|
| Tname i1, Tname i2 -> eq i1 i2
|
|
| Tmain, Tmain | Tnone, Tnone -> true
|
|
| _ -> false
|
|
|
|
let eq_titles eq t1 t2 =
|
|
eq_title_names eq t1.t_name t2.t_name
|
|
&& eq t1.t_ident t2.t_ident && eq t1.t_place t2.t_place
|
|
&& t1.t_date_start = t2.t_date_start
|
|
&& t1.t_date_end = t2.t_date_end
|
|
&& t1.t_nth = t2.t_nth
|