1703 lines
59 KiB
OCaml
1703 lines
59 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Geneweb
|
|
open Gwcomp
|
|
open Def
|
|
|
|
(* From OCaml manual, integer in binary format is 4 bytes long. *)
|
|
let sizeof_long = 4
|
|
|
|
(** Default source field for persons and families without source data *)
|
|
let default_source = ref ""
|
|
|
|
(** Base consistency check *)
|
|
let do_check = ref true
|
|
|
|
(** Compute consanguinity *)
|
|
let do_consang = ref false
|
|
|
|
(** Print base's statistics *)
|
|
let pr_stats = ref false
|
|
|
|
type person = (int, int, int) Def.gen_person
|
|
(** Extended person's entry in the base *)
|
|
|
|
type ascend = int Def.gen_ascend
|
|
(** Person's ascendants entry in the base *)
|
|
|
|
type union = int Def.gen_union
|
|
(** Person's union entry in the base *)
|
|
|
|
type family = (int, int, int) Def.gen_family
|
|
(** Family's entry in the base *)
|
|
|
|
type couple = int Def.gen_couple
|
|
(** Family's couple entry in the base *)
|
|
|
|
type descend = int Def.gen_descend
|
|
(** Family's descendants entry in the base *)
|
|
|
|
type ('person, 'string) gen_min_person = {
|
|
mutable m_first_name : 'string;
|
|
mutable m_surname : 'string;
|
|
mutable m_occ : int;
|
|
mutable m_rparents : ('person, 'string) gen_relation list;
|
|
mutable m_related : int list;
|
|
mutable m_pevents : ('person, 'string) gen_pers_event list;
|
|
mutable m_sex : sex;
|
|
mutable m_notes : 'string;
|
|
}
|
|
(** Restricted to the minimum [Def.gen_person] data type. *)
|
|
|
|
type min_person = (int, int) gen_min_person
|
|
(** Person's entry in the base *)
|
|
|
|
type cbase = {
|
|
(* Array of persons. Person at position [i] has corresponding to him [ascend]
|
|
and [union] at position [i] in [c_ascends] and [c_unions] respectively. *)
|
|
mutable c_persons : min_person array; (* Array of ascendants of persons *)
|
|
mutable c_ascends : ascend array; (* Array of unions of persons *)
|
|
mutable c_unions : union array;
|
|
(* Array of families. Family at position [i] has corresponding to it [couple]
|
|
and [descend] at position [i] in [c_couples] and [c_descends] respectively. *)
|
|
mutable c_families : family array; (** Array of couples of families *)
|
|
mutable c_couples : couple array; (* Array of descendants of families *)
|
|
mutable c_descends : descend array;
|
|
(* Array of unique strings. Stores every string encoded information
|
|
(like person's name, bithplace, etc.) for other entries in the base. *)
|
|
mutable c_strings : string array;
|
|
(* Data base notes and extended page structure *)
|
|
mutable c_bnotes : Def.base_notes;
|
|
}
|
|
(** State of the base collecting all information at link time used to
|
|
create further Geneweb database *)
|
|
|
|
type file_info = {
|
|
(* current .gw filename *)
|
|
mutable f_curr_src_file : string; (* current .gwo filename *)
|
|
mutable f_curr_gwo_file : string;
|
|
(* all persons from current file should be separated *)
|
|
mutable f_separate : bool; (* behavior for base notes from current file *)
|
|
mutable f_bnotes : [ `merge | `erase | `first | `drop ];
|
|
(* shift all persons from the current file with the given number *)
|
|
mutable f_shift : int;
|
|
(* Table that associates person's names hash and its occurence number
|
|
with the index of person's entry inside the [base]. Contains only
|
|
persons from the local file. *)
|
|
mutable f_local_names : (int * int, int) Hashtbl.t;
|
|
}
|
|
(** Information about current .gwo file. *)
|
|
|
|
type gen = {
|
|
(* Table that associates unique string to its position inside
|
|
[g_base]'s unique string array *)
|
|
mutable g_strings : (string, int) Hashtbl.t;
|
|
(* Table that associates person's names hash with the index of
|
|
person's entry inside the [g_base].*)
|
|
mutable g_names : (int, int) Hashtbl.t;
|
|
(* Counter of persons inside [g_base] *)
|
|
mutable g_pcnt : int;
|
|
(* Counter of families inside [g_base] *)
|
|
mutable g_fcnt : int;
|
|
(* Counter of unique strings inside [g_base] *)
|
|
mutable g_scnt : int;
|
|
(* Current file info *)
|
|
g_file_info : file_info;
|
|
(* Base of collected information *)
|
|
g_base : cbase;
|
|
(* Wizard notes (wizard id and note's content) *)
|
|
mutable g_wiznotes : (string * string) list;
|
|
g_patch_p : (int, person) Hashtbl.t;
|
|
(** Array that for every person from [g_base] says if he
|
|
was defined before *)
|
|
mutable g_def : bool array;
|
|
(* Table that associates person's first and last name with
|
|
the next availiable occurence number for the person with
|
|
the same names.*)
|
|
g_first_av_occ : (string * string, int) Hashtbl.t;
|
|
(* Indicates if an error was occured *)
|
|
mutable g_errored : bool;
|
|
(* Temprary output chanel containing [g_pcnt] integers where [i]nth integer
|
|
corresponds to the position in [g_per] where [i]nth person is defined. *)
|
|
g_per_index : out_channel;
|
|
(* Temprary output chanel containing person's definition (or non-definition
|
|
marker) *)
|
|
g_per : out_channel;
|
|
(* Temprary output chanel containing [g_fcnt] integers where [i]nth integer
|
|
corresponds to the position in [g_fam] where [i]nth family is defined. *)
|
|
g_fam_index : out_channel;
|
|
(* Temprary output chanel containing family's definition *)
|
|
g_fam : out_channel;
|
|
}
|
|
(** Global linker state *)
|
|
|
|
(** Set [gen.g_errored] telling that an error was occured *)
|
|
let check_error gen = gen.g_errored <- true
|
|
|
|
(** Function that will be called if base's checker will find an error *)
|
|
let set_error base gen x =
|
|
Printf.printf "\nError: ";
|
|
Check.print_base_error stdout base x;
|
|
check_error gen
|
|
|
|
(** Function that will be called if base's checker will find a warning *)
|
|
let set_warning base x =
|
|
Printf.printf "Warning: ";
|
|
Check.print_base_warning stdout base x
|
|
|
|
(** Returns person's entry from [base] at position [i] *)
|
|
let poi base i = base.c_persons.(i)
|
|
|
|
(** Returns ascendant's entry from [base] at position [i] *)
|
|
let aoi base i = base.c_ascends.(i)
|
|
|
|
(** Returns union's entry from [base] at position [i] *)
|
|
let uoi base i = base.c_unions.(i)
|
|
|
|
(** Returns couple's entry from [base] at position [i] *)
|
|
let coi base i = base.c_couples.(i)
|
|
|
|
(** Returns string in [base]'s unque string array at position [i] *)
|
|
let sou base i = base.c_strings.(i)
|
|
|
|
(** Returns first name of a [base]'s person entry [p]. [p.m_first_name] contains
|
|
index where first name string representation is stored. *)
|
|
let p_first_name base p = Mutil.nominative (sou base p.m_first_name)
|
|
|
|
(** Returns surname of a [base]'s person entry [p]. [p.m_first_name] contains
|
|
index where surname string representation is stored. *)
|
|
let p_surname base p = Mutil.nominative (sou base p.m_surname)
|
|
|
|
(** Returns string designation of person {i firstname.occ surname}. *)
|
|
let designation base p =
|
|
let prenom = p_first_name base p in
|
|
let nom = p_surname base p in
|
|
prenom ^ "." ^ string_of_int p.m_occ ^ " " ^ nom
|
|
|
|
(** Same as [Marshal.to_channel oc v [Marshal.No_sharing]] *)
|
|
let output_item_value oc v = Marshal.to_channel oc v [ Marshal.No_sharing ]
|
|
|
|
(** Same as [input_value] *)
|
|
let input_item_value ic = input_value ic
|
|
|
|
(** Empty string *)
|
|
let no_string = ""
|
|
|
|
(** Stores unique string (if not already present) inside the base's string array and
|
|
associate this string to its index in mentioned array. Extens array if needed.
|
|
Returns associated index. *)
|
|
let unique_string gen x =
|
|
try Hashtbl.find gen.g_strings x
|
|
with Not_found ->
|
|
(* string not found *)
|
|
if gen.g_scnt = Array.length gen.g_base.c_strings then (
|
|
(* extend arrray of strings and copy previus elements *)
|
|
let arr = gen.g_base.c_strings in
|
|
let new_size = (2 * Array.length arr) + 1 in
|
|
let new_arr = Array.make new_size no_string in
|
|
Array.blit arr 0 new_arr 0 (Array.length arr);
|
|
gen.g_base.c_strings <- new_arr);
|
|
let u = gen.g_scnt in
|
|
gen.g_base.c_strings.(gen.g_scnt) <- x;
|
|
gen.g_scnt <- gen.g_scnt + 1;
|
|
Hashtbl.add gen.g_strings x u;
|
|
u
|
|
|
|
(** Dummy [family] with its empty [couple] and [descendants]. *)
|
|
let no_family gen =
|
|
let empty_string = unique_string gen "" in
|
|
let fam =
|
|
{
|
|
marriage = Date.cdate_None;
|
|
marriage_place = empty_string;
|
|
marriage_note = empty_string;
|
|
marriage_src = empty_string;
|
|
witnesses = [||];
|
|
relation = NoMention;
|
|
divorce = NotDivorced;
|
|
fevents = [];
|
|
comment = empty_string;
|
|
origin_file = empty_string;
|
|
fsources = empty_string;
|
|
fam_index = -1;
|
|
}
|
|
in
|
|
let cpl = Adef.couple 0 0 in
|
|
let des = { children = [||] } in
|
|
(fam, cpl, des)
|
|
|
|
(** Initialises [min_person] with occurence number and index of [p] for first name and
|
|
index of [n] for surname in [base]. Other fields are initialised with default value.
|
|
Returns also empty [ascend] and [union] attached to the considered person. *)
|
|
let make_person gen p n occ : min_person * ascend * union =
|
|
let empty_string = unique_string gen "" in
|
|
let p =
|
|
{
|
|
m_first_name = unique_string gen p;
|
|
m_surname = unique_string gen n;
|
|
m_occ = occ;
|
|
m_rparents = [];
|
|
m_related = [];
|
|
m_pevents = [];
|
|
m_sex = Neuter;
|
|
m_notes = empty_string;
|
|
}
|
|
and a = { parents = None; consang = Adef.fix (-1) }
|
|
and u = { family = [||] } in
|
|
(p, a, u)
|
|
|
|
(** Dummy [min_person] with its empty [ascend] and [union]. *)
|
|
let no_person gen = make_person gen "" "" 0
|
|
|
|
(** Extends person's acendant's and union's arrays inside [gen.g_base]
|
|
if needed. *)
|
|
let new_iper gen =
|
|
if gen.g_pcnt = Array.length gen.g_base.c_persons then (
|
|
let per_arr = gen.g_base.c_persons in
|
|
let asc_arr = gen.g_base.c_ascends in
|
|
let uni_arr = gen.g_base.c_unions in
|
|
let new_size = (2 * Array.length per_arr) + 1 in
|
|
let phony_per, phony_asc, phony_uni = no_person gen in
|
|
let new_per_arr = Array.make new_size phony_per in
|
|
let new_asc_arr = Array.make new_size phony_asc in
|
|
let new_uni_arr = Array.make new_size phony_uni in
|
|
let new_def = Array.make new_size false in
|
|
Array.blit per_arr 0 new_per_arr 0 (Array.length per_arr);
|
|
gen.g_base.c_persons <- new_per_arr;
|
|
Array.blit asc_arr 0 new_asc_arr 0 (Array.length asc_arr);
|
|
gen.g_base.c_ascends <- new_asc_arr;
|
|
Array.blit uni_arr 0 new_uni_arr 0 (Array.length uni_arr);
|
|
gen.g_base.c_unions <- new_uni_arr;
|
|
Array.blit gen.g_def 0 new_def 0 (Array.length gen.g_def);
|
|
gen.g_def <- new_def)
|
|
|
|
(** Extends family's couple's and decendant's arrays inside [gen.g_base]
|
|
if needed. *)
|
|
let new_ifam gen =
|
|
if gen.g_fcnt = Array.length gen.g_base.c_families then (
|
|
let fam_arr = gen.g_base.c_families in
|
|
let cpl_arr = gen.g_base.c_couples in
|
|
let des_arr = gen.g_base.c_descends in
|
|
let new_size = (2 * Array.length cpl_arr) + 1 in
|
|
let phony_fam, phony_cpl, phony_des = no_family gen in
|
|
let new_fam_arr = Array.make new_size phony_fam in
|
|
let new_cpl_arr = Array.make new_size phony_cpl in
|
|
let new_des_arr = Array.make new_size phony_des in
|
|
Array.blit fam_arr 0 new_fam_arr 0 (Array.length fam_arr);
|
|
gen.g_base.c_families <- new_fam_arr;
|
|
Array.blit cpl_arr 0 new_cpl_arr 0 (Array.length cpl_arr);
|
|
gen.g_base.c_couples <- new_cpl_arr;
|
|
Array.blit des_arr 0 new_des_arr 0 (Array.length des_arr);
|
|
gen.g_base.c_descends <- new_des_arr)
|
|
|
|
(** Convert [string Def.gen_title_name] to [int Def.gen_title_name].
|
|
If title is [Tname] stores title name as a string in the base. *)
|
|
let title_name_unique_string gen = function
|
|
| Tmain -> Tmain
|
|
| Tname n -> Tname (unique_string gen n)
|
|
| Tnone -> Tnone
|
|
|
|
(** Convert [(string Def.gen_title] to [int Def.gen_title] and insert
|
|
all related to title information in the base. *)
|
|
let title_unique_string gen t =
|
|
{
|
|
t_name = title_name_unique_string gen t.t_name;
|
|
t_ident = unique_string gen t.t_ident;
|
|
t_place = unique_string gen t.t_place;
|
|
t_date_start = t.t_date_start;
|
|
t_date_end = t.t_date_end;
|
|
t_nth = t.t_nth;
|
|
}
|
|
|
|
(** Hash of person's first and last names. *)
|
|
let person_hash first_name surname =
|
|
let first_name = Mutil.nominative first_name in
|
|
let surname = Mutil.nominative surname in
|
|
let s = Name.crush_lower (first_name ^ " " ^ surname) in
|
|
Hashtbl.hash s
|
|
|
|
(** Returns index of a person's entry inside the [gen.base] that has the same
|
|
first name, surname and occurence number. Raises [Not_found] if person
|
|
is not found. *)
|
|
let find_person_by_global_name gen first_name surname occ =
|
|
let first_name = Mutil.nominative first_name in
|
|
let surname = Mutil.nominative surname in
|
|
let s = Name.crush_lower (first_name ^ " " ^ surname) in
|
|
let key = Hashtbl.hash s in
|
|
let ipl = Hashtbl.find_all gen.g_names key in
|
|
let first_name = Name.lower first_name in
|
|
let surname = Name.lower surname in
|
|
let rec loop = function
|
|
| [] -> raise Not_found
|
|
| ip :: ipl ->
|
|
let p = poi gen.g_base ip in
|
|
(* refine search by fullnames comparison (without crushlower) and with
|
|
occurence comparison *)
|
|
if
|
|
p.m_occ = occ
|
|
&& Name.lower (p_first_name gen.g_base p) = first_name
|
|
&& Name.lower (p_surname gen.g_base p) = surname
|
|
then ip
|
|
else loop ipl
|
|
in
|
|
loop ipl
|
|
|
|
(** Returns index of a person's entry inside the [gen.base] that has the same
|
|
first name, surname and occurence number. Searches only persons defined
|
|
in the current file. Raises [Not_found] if person is not found. *)
|
|
let find_person_by_local_name gen first_name surname occ =
|
|
let first_name = Mutil.nominative first_name in
|
|
let surname = Mutil.nominative surname in
|
|
let s = Name.crush_lower (first_name ^ " " ^ surname) in
|
|
let key = Hashtbl.hash s in
|
|
let ipl = Hashtbl.find_all gen.g_file_info.f_local_names (key, occ) in
|
|
let first_name = Name.lower first_name in
|
|
let surname = Name.lower surname in
|
|
let rec loop = function
|
|
| [] -> raise Not_found
|
|
| ip :: ipl ->
|
|
let p = poi gen.g_base ip in
|
|
(* refine search by fullnames comparison (without crushlower) *)
|
|
if
|
|
Name.lower (p_first_name gen.g_base p) = first_name
|
|
&& Name.lower (p_surname gen.g_base p) = surname
|
|
then ip
|
|
else loop ipl
|
|
in
|
|
loop ipl
|
|
|
|
(** Returns index of a person's entry inside the [gen.base] that has the same
|
|
first name, surname and occurence number. Calls [find_person_by_local_name]
|
|
if option [f_separate] is enabled for the current file, otherwise calls
|
|
[find_person_by_global_name]. Raises [Not_found] if person is not found. *)
|
|
let find_person_by_name gen first_name surname occ =
|
|
if gen.g_file_info.f_separate then
|
|
find_person_by_local_name gen first_name surname occ
|
|
else find_person_by_global_name gen first_name surname occ
|
|
|
|
(** Add entry in the global names table [gen.g_names] for the giving
|
|
first and last names associated to the index of their person's entry
|
|
in [base]. *)
|
|
let add_person_by_name gen first_name surname int =
|
|
let s = Name.crush_lower (Mutil.nominative (first_name ^ " " ^ surname)) in
|
|
let key = Hashtbl.hash s in
|
|
Hashtbl.add gen.g_names key int
|
|
|
|
(** Returns first available occurence number that is >= [occ] for the person
|
|
with the giving information. *)
|
|
let find_first_available_occ gen fn sn occ =
|
|
let occ =
|
|
try max occ (Hashtbl.find gen.g_first_av_occ (fn, sn))
|
|
with Not_found -> occ
|
|
in
|
|
let rec loop occ =
|
|
match
|
|
try Some (find_person_by_global_name gen fn sn occ)
|
|
with Not_found -> None
|
|
with
|
|
| Some _ -> loop (occ + 1)
|
|
| None ->
|
|
Hashtbl.add gen.g_first_av_occ (fn, sn) occ;
|
|
occ
|
|
in
|
|
loop occ
|
|
|
|
(** Insert person's reference in the base and modifies all coresponding
|
|
fields in [gen] and returns its entry and entry's index in the base.
|
|
In details:
|
|
|
|
- if considered person doesn't exists in the base (wasn't defined or
|
|
referenced before) then function:
|
|
|
|
- maps its key (names and occurence number) within the varius
|
|
hash tables
|
|
- creates entry (of type [min_gen]) for the giving person and his
|
|
ascendants and union in the base.
|
|
- initialises its entry (with key information)
|
|
- stores marker in the [gen.g_per] channel telling that person
|
|
wasn't defined.
|
|
- stores in [gen.g_per_index] position where marker was stored in
|
|
[gen.g_per].
|
|
|
|
- if considered person was referenced or defined before then doesn't do
|
|
anything (just returns its entry and entry's index in the base)
|
|
|
|
*)
|
|
let insert_undefined gen key =
|
|
(* shift person's occurence *)
|
|
let occ = key.pk_occ + gen.g_file_info.f_shift in
|
|
(* person with its position in the base *)
|
|
let x, ip =
|
|
try
|
|
if key.pk_first_name = "?" || key.pk_surname = "?" then raise Not_found
|
|
else
|
|
let ip = find_person_by_name gen key.pk_first_name key.pk_surname occ in
|
|
(poi gen.g_base ip, ip) (* if person not found *)
|
|
with Not_found ->
|
|
(* available occurence number *)
|
|
let new_occ =
|
|
if
|
|
gen.g_file_info.f_separate && key.pk_first_name <> "?"
|
|
&& key.pk_surname <> "?"
|
|
then find_first_available_occ gen key.pk_first_name key.pk_surname occ
|
|
else occ
|
|
in
|
|
(* person's entry index *)
|
|
let i = gen.g_pcnt in
|
|
let x, a, u = make_person gen key.pk_first_name key.pk_surname new_occ in
|
|
(* strore names globally *)
|
|
if key.pk_first_name <> "?" && key.pk_surname <> "?" then
|
|
add_person_by_name gen key.pk_first_name key.pk_surname i
|
|
else if !Gwcomp.create_all_keys then
|
|
add_person_by_name gen key.pk_first_name key.pk_surname i;
|
|
(* extend arrays if needed *)
|
|
new_iper gen;
|
|
(* add person to array *)
|
|
gen.g_base.c_persons.(i) <- x;
|
|
(* add associated to person ascendants to array *)
|
|
gen.g_base.c_ascends.(i) <- a;
|
|
(* add associated to person union to array *)
|
|
gen.g_base.c_unions.(i) <- u;
|
|
gen.g_pcnt <- gen.g_pcnt + 1;
|
|
(* strore names locally *)
|
|
(if key.pk_first_name <> "?" && key.pk_surname <> "?" then
|
|
let h = person_hash key.pk_first_name key.pk_surname in
|
|
Hashtbl.add gen.g_file_info.f_local_names (h, occ) i);
|
|
(* write start position of person in [g_per] *)
|
|
seek_out gen.g_per_index (sizeof_long * i);
|
|
output_binary_int gen.g_per_index (pos_out gen.g_per);
|
|
(* write marker *)
|
|
output_char gen.g_per 'U';
|
|
(x, i)
|
|
in
|
|
if not gen.g_errored then
|
|
if
|
|
sou gen.g_base x.m_first_name <> key.pk_first_name
|
|
|| sou gen.g_base x.m_surname <> key.pk_surname
|
|
then (
|
|
Printf.printf "\nPerson defined with two spellings:\n";
|
|
Printf.printf " \"%s%s %s\"\n" key.pk_first_name
|
|
(match x.m_occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
key.pk_surname;
|
|
Printf.printf " \"%s%s %s\"\n"
|
|
(p_first_name gen.g_base x)
|
|
(match occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
(p_surname gen.g_base x);
|
|
gen.g_def.(ip) <- true;
|
|
check_error gen);
|
|
(x, ip)
|
|
|
|
(** Insert person's definition in the base and modifies all coresponding
|
|
fields in [gen] and returns its entry and entry's index in the base.
|
|
In details:
|
|
|
|
- if considered person doesn't exists in the base (wasn't defined or
|
|
referenced before) then function:
|
|
|
|
- maps its key (names and occurence number) within the varius
|
|
hash tables
|
|
- creates entry (of type [min_gen]) for the giving person and his
|
|
ascendants and union in the base.
|
|
- initialises its entry (with key information)
|
|
- marks it as defined
|
|
- convert [(_,_,string) gen_person] to [person] (sex, events, titles
|
|
and related persons stays uninitialised) and stores it in the
|
|
[gen.g_per] channel.
|
|
- stores in [gen.g_per_index] position where person was stored in
|
|
[gen.g_per].
|
|
|
|
- if considered person was referenced before (but not defined) then
|
|
function:
|
|
|
|
- get person's entry and its index from the base
|
|
- marks it as defined
|
|
- convert [(_,_,string) gen_person] to [person] (sex, events and
|
|
related persons stays uninitialised) and stores it in the
|
|
[gen.g_per] channel.
|
|
- updates previus index in [gen.g_per_index] in order to point to
|
|
the definition instead of pointing to the reference.
|
|
*)
|
|
let insert_person gen so =
|
|
(* shift person's occurence *)
|
|
let occ = so.occ + gen.g_file_info.f_shift in
|
|
(* person with its position in the base *)
|
|
let x, ip =
|
|
try
|
|
if so.first_name = "?" || so.surname = "?" then raise Not_found
|
|
else
|
|
let ip = find_person_by_name gen so.first_name so.surname occ in
|
|
(poi gen.g_base ip, ip) (* if person not found *)
|
|
with Not_found ->
|
|
(* available occurence number *)
|
|
let new_occ =
|
|
if
|
|
gen.g_file_info.f_separate && so.first_name <> "?"
|
|
&& so.surname <> "?"
|
|
then find_first_available_occ gen so.first_name so.surname occ
|
|
else occ
|
|
in
|
|
(* person's entry index *)
|
|
let i = gen.g_pcnt in
|
|
let x, a, u = make_person gen so.first_name so.surname new_occ in
|
|
(* strore names globally *)
|
|
if so.first_name <> "?" && so.surname <> "?" then
|
|
add_person_by_name gen so.first_name so.surname i
|
|
else if !Gwcomp.create_all_keys then
|
|
add_person_by_name gen so.first_name so.surname i;
|
|
(* extend arrays if needed *)
|
|
new_iper gen;
|
|
(* add person to array *)
|
|
gen.g_base.c_persons.(i) <- x;
|
|
(* add associated to person ascendants to array *)
|
|
gen.g_base.c_ascends.(i) <- a;
|
|
(* add associated to person union to array *)
|
|
gen.g_base.c_unions.(i) <- u;
|
|
gen.g_pcnt <- gen.g_pcnt + 1;
|
|
(* strore names locally *)
|
|
(if so.first_name <> "?" && so.surname <> "?" then
|
|
let h = person_hash so.first_name so.surname in
|
|
Hashtbl.add gen.g_file_info.f_local_names (h, occ) i);
|
|
(x, i)
|
|
in
|
|
(* if person wad defined before (not just referenced) *)
|
|
if gen.g_def.(ip) then (
|
|
(* print error about person beeing already defined *)
|
|
Printf.printf "\nPerson already defined: \"%s%s %s\"\n" so.first_name
|
|
(match x.m_occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
so.surname;
|
|
if
|
|
p_first_name gen.g_base x <> so.first_name
|
|
|| p_surname gen.g_base x <> so.surname
|
|
then
|
|
Printf.printf "as name: \"%s%s %s\"\n"
|
|
(p_first_name gen.g_base x)
|
|
(match occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
(p_surname gen.g_base x);
|
|
flush stdout;
|
|
check_error gen)
|
|
else (* else set it as defined *)
|
|
gen.g_def.(ip) <- true;
|
|
if not gen.g_errored then
|
|
if
|
|
sou gen.g_base x.m_first_name <> so.first_name
|
|
|| sou gen.g_base x.m_surname <> so.surname
|
|
then (
|
|
(* print error about person defined with two spellings *)
|
|
Printf.printf "\nPerson defined with two spellings:\n";
|
|
Printf.printf " \"%s%s %s\"\n" so.first_name
|
|
(match x.m_occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
so.surname;
|
|
Printf.printf " \"%s%s %s\"\n"
|
|
(p_first_name gen.g_base x)
|
|
(match occ with 0 -> "" | n -> "." ^ string_of_int n)
|
|
(p_surname gen.g_base x);
|
|
gen.g_def.(ip) <- true;
|
|
check_error gen);
|
|
if not gen.g_errored then (
|
|
let empty_string = unique_string gen "" in
|
|
(* Convert [(_,_,string) gen_person] to [person]. Save all strings in base *)
|
|
let x =
|
|
{
|
|
first_name = empty_string;
|
|
surname = empty_string;
|
|
occ = 0;
|
|
image = unique_string gen so.image;
|
|
first_names_aliases =
|
|
List.map (unique_string gen) so.first_names_aliases;
|
|
surnames_aliases = List.map (unique_string gen) so.surnames_aliases;
|
|
public_name = unique_string gen so.public_name;
|
|
qualifiers = List.map (unique_string gen) so.qualifiers;
|
|
aliases = List.map (unique_string gen) so.aliases;
|
|
titles = List.map (title_unique_string gen) so.titles;
|
|
rparents = [];
|
|
related = [];
|
|
occupation = unique_string gen so.occupation;
|
|
sex = Neuter;
|
|
access = so.access;
|
|
birth = so.birth;
|
|
birth_place = unique_string gen so.birth_place;
|
|
birth_note = unique_string gen so.birth_note;
|
|
birth_src = unique_string gen so.birth_src;
|
|
baptism = so.baptism;
|
|
baptism_place = unique_string gen so.baptism_place;
|
|
baptism_note = unique_string gen so.baptism_note;
|
|
baptism_src = unique_string gen so.baptism_src;
|
|
death = so.death;
|
|
death_place = unique_string gen so.death_place;
|
|
death_note = unique_string gen so.death_note;
|
|
death_src = unique_string gen so.death_src;
|
|
burial = so.burial;
|
|
burial_place = unique_string gen so.burial_place;
|
|
burial_note = unique_string gen so.burial_note;
|
|
burial_src = unique_string gen so.burial_src;
|
|
pevents = [];
|
|
notes = empty_string;
|
|
psources =
|
|
unique_string gen
|
|
(if so.psources = "" then !default_source else so.psources);
|
|
key_index = ip;
|
|
}
|
|
in
|
|
(* write/update start position of person in [g_per] *)
|
|
seek_out gen.g_per_index (sizeof_long * ip);
|
|
output_binary_int gen.g_per_index (pos_out gen.g_per);
|
|
(* write person *)
|
|
output_char gen.g_per 'D';
|
|
output_item_value gen.g_per (x : person));
|
|
(x, ip)
|
|
|
|
(** Insert definition or reference in [gen] and returns its entry and
|
|
entry's index in the [gen.g_base]. Calls [insert_person] for definition
|
|
and [insert_undefined] for reference. *)
|
|
let insert_somebody gen = function
|
|
| Undefined key -> insert_undefined gen key
|
|
| Defined so -> insert_person gen so
|
|
|
|
(** Checks if children [ix] doesn't have another parents *)
|
|
let check_parents_not_already_defined gen ix fath moth =
|
|
let x = poi gen.g_base ix in
|
|
match (aoi gen.g_base ix).parents with
|
|
| Some int ->
|
|
let cpl = coi gen.g_base int in
|
|
let p = Adef.father cpl in
|
|
let m = Adef.mother cpl in
|
|
Printf.printf
|
|
"I cannot add \"%s\", child of\n\
|
|
\ - \"%s\"\n\
|
|
\ - \"%s\",\n\
|
|
because this persons still exists as child of\n\
|
|
\ - \"%s\"\n\
|
|
\ - \"%s\"." (designation gen.g_base x)
|
|
(designation gen.g_base fath)
|
|
(designation gen.g_base moth)
|
|
(designation gen.g_base (poi gen.g_base p))
|
|
(designation gen.g_base (poi gen.g_base m));
|
|
flush stdout;
|
|
(*
|
|
x.birth := Adef.cdate_None;
|
|
x.death := DontKnowIfDead;
|
|
*)
|
|
check_error gen
|
|
| _ -> ()
|
|
|
|
(** Assign sex to the person's entry if it's unitialised.
|
|
Print message if sexes are different. *)
|
|
let notice_sex gen p s =
|
|
if p.m_sex = Neuter then p.m_sex <- s
|
|
else if p.m_sex <> s && s <> Neuter then
|
|
Printf.printf "\nInconsistency about the sex of\n %s %s\n"
|
|
(p_first_name gen.g_base p)
|
|
(p_surname gen.g_base p)
|
|
|
|
(** Convert [string Def.gen_fam_event_name] to [int Def.gen_fam_event_name].
|
|
If event is [Efam_Name] stores event name as a string in the base. *)
|
|
let fevent_name_unique_string gen = function
|
|
| ( 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 n -> Efam_Name (unique_string gen n)
|
|
|
|
(** Update family by looking up information inferred from family events *)
|
|
let update_family_with_fevents _gen fam =
|
|
let found_marriage = ref false in
|
|
let found_divorce = ref false in
|
|
let nsck_std_fields =
|
|
match fam.relation with
|
|
| NoSexesCheckNotMarried | NoSexesCheckMarried -> true
|
|
| _ -> false
|
|
in
|
|
(* On veut cette fois ci que ce soit le dernier évènement *)
|
|
(* qui soit mis dans les évènements principaux. *)
|
|
let convert relation =
|
|
match relation with
|
|
| Efam_Marriage ->
|
|
if nsck_std_fields then Some NoSexesCheckMarried else Some Married
|
|
| Efam_NoMarriage ->
|
|
if nsck_std_fields then Some NoSexesCheckNotMarried else Some NotMarried
|
|
| Efam_Engage -> Some Engaged
|
|
| Efam_NoMention -> Some NoMention
|
|
| Efam_MarriageBann -> Some MarriageBann
|
|
| Efam_MarriageContract -> Some MarriageContract
|
|
| Efam_MarriageLicense -> Some MarriageLicense
|
|
| Efam_PACS -> Some Pacs
|
|
| Efam_Residence -> Some Residence
|
|
| _ -> None
|
|
in
|
|
let rec loop fevents fam =
|
|
match fevents with
|
|
| [] -> fam
|
|
| evt :: l -> (
|
|
match convert evt.efam_name with
|
|
| Some relation' ->
|
|
if !found_marriage then loop l fam
|
|
else
|
|
let witnesses = Array.map fst evt.efam_witnesses in
|
|
let fam =
|
|
{
|
|
fam with
|
|
relation = relation';
|
|
marriage = evt.efam_date;
|
|
marriage_place = evt.efam_place;
|
|
marriage_note = evt.efam_note;
|
|
marriage_src = evt.efam_src;
|
|
witnesses;
|
|
}
|
|
in
|
|
let () = found_marriage := true in
|
|
loop l fam
|
|
| None -> (
|
|
match evt.efam_name with
|
|
| Efam_Divorce ->
|
|
if !found_divorce then loop l fam
|
|
else
|
|
let fam = { fam with divorce = Divorced evt.efam_date } in
|
|
let () = found_divorce := true in
|
|
loop l fam
|
|
| Efam_Separated ->
|
|
if !found_divorce then loop l fam
|
|
else
|
|
let fam = { fam with divorce = Separated } in
|
|
let () = found_divorce := true in
|
|
loop l fam
|
|
| _ -> loop l fam))
|
|
in
|
|
loop (List.rev fam.fevents) fam
|
|
|
|
(** Update family event list by looking up inferred family information. *)
|
|
let update_fevents_with_family gen fam =
|
|
let empty_string = 0 in
|
|
let evt_marr =
|
|
let name =
|
|
match fam.relation with
|
|
| Married -> Efam_Marriage
|
|
| NotMarried -> Efam_NoMarriage
|
|
| Engaged -> Efam_Engage
|
|
| NoSexesCheckNotMarried -> Efam_NoMarriage
|
|
| NoMention -> Efam_NoMention
|
|
| NoSexesCheckMarried -> Efam_Marriage
|
|
| MarriageBann -> Efam_MarriageBann
|
|
| MarriageContract -> Efam_MarriageContract
|
|
| MarriageLicense -> Efam_MarriageLicense
|
|
| Pacs -> Efam_PACS
|
|
| Residence -> Efam_Residence
|
|
in
|
|
let witnesses = Array.map (fun ip -> (ip, Witness)) fam.witnesses in
|
|
let evt =
|
|
{
|
|
efam_name = name;
|
|
efam_date = fam.marriage;
|
|
efam_place = fam.marriage_place;
|
|
efam_reason = empty_string;
|
|
efam_note = fam.marriage_note;
|
|
efam_src = fam.marriage_src;
|
|
efam_witnesses = witnesses;
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let evt_div =
|
|
match fam.divorce with
|
|
| NotDivorced -> None
|
|
| Divorced cd ->
|
|
let evt =
|
|
{
|
|
efam_name = Efam_Divorce;
|
|
efam_date = cd;
|
|
efam_place = unique_string gen "";
|
|
efam_reason = unique_string gen "";
|
|
efam_note = unique_string gen "";
|
|
efam_src = unique_string gen "";
|
|
efam_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| Separated ->
|
|
let evt =
|
|
{
|
|
efam_name = Efam_Separated;
|
|
efam_date = Date.cdate_None;
|
|
efam_place = unique_string gen "";
|
|
efam_reason = unique_string gen "";
|
|
efam_note = unique_string gen "";
|
|
efam_src = unique_string gen "";
|
|
efam_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let fevents = [ evt_marr; evt_div ] in
|
|
let fevents =
|
|
List.fold_right
|
|
(fun evt fevents ->
|
|
match evt with Some evt -> evt :: fevents | None -> fevents)
|
|
fevents []
|
|
in
|
|
{ fam with fevents }
|
|
|
|
(** Insert family in the base and modifies all coresponding
|
|
fields in [gen] and returns its entry and entry's index in the base.
|
|
In details function does:
|
|
|
|
- inserts father and mother in the person's base
|
|
- insert every witness in the person's base and associate father
|
|
as a related person.
|
|
- order, convert, adjust and insert events
|
|
- insert every children in the person's base
|
|
- creates entry (of type [family]) for the giving family and its
|
|
couple and descendants in the base.
|
|
- associate father's and mother's union to the current family
|
|
- associate every children's ascendants to the current family
|
|
(current couple, since it has the same index)
|
|
- stores family in the [gen.g_fam] channel.
|
|
- stores in [gen.g_fam_index] position where person was stored in
|
|
[gen.g_index].
|
|
*)
|
|
let insert_family gen co fath_sex moth_sex witl fevtl fo deo =
|
|
let fath, ifath, moth, imoth =
|
|
match
|
|
( insert_somebody gen (Adef.father co),
|
|
insert_somebody gen (Adef.mother co) )
|
|
with
|
|
(* Look for inverted WIFE/HUSB *)
|
|
| (fath, ifath), (moth, imoth) when fath.m_sex = Female && moth.m_sex = Male
|
|
->
|
|
(moth, imoth, fath, ifath)
|
|
| (fath, ifath), (moth, imoth) -> (fath, ifath, moth, imoth)
|
|
in
|
|
(* insert all family witnesses *)
|
|
let witl =
|
|
List.map
|
|
(fun (wit, sex) ->
|
|
let p, ip = insert_somebody gen wit in
|
|
notice_sex gen p sex;
|
|
(* add father to witness' related persons *)
|
|
p.m_related <- ifath :: p.m_related;
|
|
ip)
|
|
witl
|
|
in
|
|
(* Events are sorted by chronological order (if equal then by alphabetical order) *)
|
|
let fevents =
|
|
Event.sort_events
|
|
(fun (name, _, _, _, _, _, _) -> Event.Fevent name)
|
|
(fun (_, date, _, _, _, _, _) -> date)
|
|
fevtl
|
|
in
|
|
(* Create [int Def.gen_fam_event_name] list from [fevents]*)
|
|
let fevents =
|
|
List.map
|
|
(fun (name, date, place, reason, src, notes, witl) ->
|
|
(* insert all event witnesses *)
|
|
let witnesses =
|
|
List.map
|
|
(fun (wit, sex, wk) ->
|
|
let p, ip = insert_somebody gen wit in
|
|
notice_sex gen p sex;
|
|
p.m_related <- ifath :: p.m_related;
|
|
(ip, wk))
|
|
witl
|
|
in
|
|
{
|
|
efam_name = fevent_name_unique_string gen name;
|
|
efam_date = date;
|
|
efam_place = unique_string gen place;
|
|
efam_reason = unique_string gen reason;
|
|
efam_note = unique_string gen notes;
|
|
efam_src = unique_string gen src;
|
|
efam_witnesses = Array.of_list witnesses;
|
|
})
|
|
fevents
|
|
in
|
|
(* insert all children *)
|
|
let children =
|
|
Array.map
|
|
(fun key ->
|
|
let e, ie = insert_person gen key in
|
|
notice_sex gen e key.sex;
|
|
ie)
|
|
deo.children
|
|
in
|
|
(* insert family comment *)
|
|
let comment = unique_string gen fo.comment in
|
|
(* insert sources comment *)
|
|
let fsources =
|
|
unique_string gen
|
|
(if fo.fsources = "" then !default_source else fo.fsources)
|
|
in
|
|
(* extend arrays if needed *)
|
|
new_ifam gen;
|
|
(* family's entry index *)
|
|
let i = gen.g_fcnt in
|
|
(* Convert [(_,_,string) gen_family] to [family]. Save all strings in base *)
|
|
let fam =
|
|
{
|
|
marriage = fo.marriage;
|
|
marriage_place = unique_string gen fo.marriage_place;
|
|
marriage_note = unique_string gen fo.marriage_note;
|
|
marriage_src = unique_string gen fo.marriage_src;
|
|
witnesses = Array.of_list witl;
|
|
relation = fo.relation;
|
|
divorce = fo.divorce;
|
|
fevents;
|
|
comment;
|
|
origin_file = unique_string gen fo.origin_file;
|
|
fsources;
|
|
fam_index = i;
|
|
}
|
|
(* create couple *)
|
|
and cpl = Adef.couple ifath imoth
|
|
(* created descandants *)
|
|
and des = { children } in
|
|
(* On mets à jour les fevents et events normaux *)
|
|
let fam =
|
|
if fevents <> [] then update_family_with_fevents gen fam
|
|
else update_fevents_with_family gen fam
|
|
in
|
|
(* father's union *)
|
|
let fath_uni = uoi gen.g_base ifath in
|
|
(* mother's union *)
|
|
let moth_uni = uoi gen.g_base imoth in
|
|
(* write start position of family in [g_fam] *)
|
|
seek_out gen.g_fam_index (sizeof_long * i);
|
|
output_binary_int gen.g_fam_index (pos_out gen.g_fam);
|
|
(* write family *)
|
|
output_item_value gen.g_fam (fam : family);
|
|
(* add family to array *)
|
|
gen.g_base.c_families.(gen.g_fcnt) <- fam;
|
|
(* add couple to array *)
|
|
gen.g_base.c_couples.(gen.g_fcnt) <- cpl;
|
|
(* add descendants to array *)
|
|
gen.g_base.c_descends.(gen.g_fcnt) <- des;
|
|
gen.g_fcnt <- gen.g_fcnt + 1;
|
|
(* append this family to father's and mother's union *)
|
|
let fath_uni = { family = Array.append fath_uni.family [| i |] } in
|
|
gen.g_base.c_unions.(ifath) <- fath_uni;
|
|
let moth_uni = { family = Array.append moth_uni.family [| i |] } in
|
|
gen.g_base.c_unions.(imoth) <- moth_uni;
|
|
notice_sex gen fath fath_sex;
|
|
notice_sex gen moth moth_sex;
|
|
(* Append familly to the children's ascendant *)
|
|
Array.iter
|
|
(fun ix ->
|
|
let a = gen.g_base.c_ascends.(ix) in
|
|
(* check if children has no another parents *)
|
|
check_parents_not_already_defined gen ix fath moth;
|
|
let a = { a with parents = Some i } in
|
|
gen.g_base.c_ascends.(ix) <- a)
|
|
children
|
|
|
|
(** Convert [string Def.gen_pers_event_name] to [int Def.gen_pers_event_name].
|
|
If event is [Epers_Name] stores event name as a string in the base. *)
|
|
let pevent_name_unique_string gen = function
|
|
| ( 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 n -> Epers_Name (unique_string gen n)
|
|
|
|
(** Insert all related to the event information and add it to the person's entry
|
|
in the [gen.g_base] *)
|
|
let insert_pevents fname gen sb pevtl =
|
|
(* insert concered person *)
|
|
let p, ip = insert_somebody gen sb in
|
|
if p.m_pevents <> [] then (
|
|
Printf.printf "\nFile \"%s\"\n" fname;
|
|
Printf.printf "Individual events already defined for \"%s%s %s\"\n"
|
|
(sou gen.g_base p.m_first_name)
|
|
(if p.m_occ = 0 then "" else "." ^ string_of_int p.m_occ)
|
|
(sou gen.g_base p.m_surname);
|
|
check_error gen)
|
|
else
|
|
(* sort evenets *)
|
|
let pevents =
|
|
Event.sort_events
|
|
(fun (name, _, _, _, _, _, _) -> Event.Pevent name)
|
|
(fun (_, date, _, _, _, _, _) -> date)
|
|
pevtl
|
|
in
|
|
(* convert evenets. Insert all related to evenet information in the base *)
|
|
let pevents =
|
|
List.map
|
|
(fun (name, date, place, reason, src, notes, witl) ->
|
|
let witnesses =
|
|
List.map
|
|
(fun (wit, sex, wk) ->
|
|
(* insert witnesses *)
|
|
let wp, wip = insert_somebody gen wit in
|
|
notice_sex gen wp sex;
|
|
(* add concerned person as witness' relation *)
|
|
wp.m_related <- ip :: wp.m_related;
|
|
(wip, wk))
|
|
witl
|
|
in
|
|
{
|
|
epers_name = pevent_name_unique_string gen name;
|
|
epers_date = date;
|
|
epers_place = unique_string gen place;
|
|
epers_reason = unique_string gen reason;
|
|
epers_note = unique_string gen notes;
|
|
epers_src = unique_string gen src;
|
|
epers_witnesses = Array.of_list witnesses;
|
|
})
|
|
pevents
|
|
in
|
|
(* add events to the person's entry in the base *)
|
|
p.m_pevents <- pevents
|
|
|
|
(** Insert person's notes in the base and associate it to the referenced
|
|
with [key] person *)
|
|
let insert_notes fname gen key str =
|
|
let occ = key.pk_occ + gen.g_file_info.f_shift in
|
|
match
|
|
try Some (find_person_by_name gen key.pk_first_name key.pk_surname occ)
|
|
with Not_found -> None
|
|
with
|
|
| Some ip ->
|
|
let p = poi gen.g_base ip in
|
|
if sou gen.g_base p.m_notes <> "" then (
|
|
Printf.printf "\nFile \"%s\"\n" fname;
|
|
Printf.printf "Notes already defined for \"%s%s %s\"\n"
|
|
key.pk_first_name
|
|
(if occ = 0 then "" else "." ^ string_of_int occ)
|
|
key.pk_surname;
|
|
check_error gen)
|
|
else p.m_notes <- unique_string gen str
|
|
| None ->
|
|
Printf.printf "File \"%s\"\n" fname;
|
|
Printf.printf "*** warning: undefined person: \"%s%s %s\"\n"
|
|
key.pk_first_name
|
|
(if occ = 0 then "" else "." ^ string_of_int occ)
|
|
key.pk_surname;
|
|
flush stdout
|
|
|
|
(** Changes [gen.g_base.c_bnotes] to take into account [nfname] page
|
|
and its content [str] that is treated by the way mentioned in
|
|
[gen.g_file_info.f_bnotes]. *)
|
|
let insert_bnotes fname gen nfname str =
|
|
if gen.g_file_info.f_bnotes <> `drop then
|
|
let old_nread = gen.g_base.c_bnotes.nread in
|
|
(* Convert path notation from 'dir1:dir2:file' to 'dir1/dir2/file'
|
|
(if a valid path) *)
|
|
let nfname =
|
|
if nfname = "" then ""
|
|
else
|
|
match NotesLinks.check_file_name nfname with
|
|
| Some (dl, f) -> List.fold_right Filename.concat dl f
|
|
| None -> "bad"
|
|
in
|
|
let bnotes =
|
|
let str =
|
|
match gen.g_file_info.f_bnotes with
|
|
| `drop -> assert false
|
|
| `erase -> str
|
|
| `merge -> old_nread nfname RnAll ^ str
|
|
| `first -> (
|
|
match old_nread nfname RnAll with "" -> str | str -> str)
|
|
in
|
|
{
|
|
nread = (fun f n -> if f = nfname then str else old_nread f n);
|
|
norigin_file = fname;
|
|
efiles =
|
|
(if nfname <> "" then
|
|
let efiles = gen.g_base.c_bnotes.efiles () in
|
|
fun () -> nfname :: efiles
|
|
else gen.g_base.c_bnotes.efiles);
|
|
}
|
|
in
|
|
gen.g_base.c_bnotes <- bnotes
|
|
|
|
(** Add wizard and his note to the [gen] *)
|
|
let insert_wiznote gen wizid str =
|
|
gen.g_wiznotes <- (wizid, str) :: gen.g_wiznotes
|
|
|
|
let map_option f = function Some x -> Some (f x) | None -> None
|
|
|
|
(** Insert parent in the base and adjust his sex if needed. Concerned
|
|
person is added in the list of parent's related persons. *)
|
|
let insert_relation_parent gen ip s k =
|
|
let par, ipar = insert_somebody gen k in
|
|
par.m_related <- ip :: par.m_related;
|
|
if par.m_sex = Neuter then par.m_sex <- s;
|
|
ipar
|
|
|
|
(** Convert [(Dune__exe.Gwcomp.somebody, string) Def.gen_relation] to
|
|
[(int, int) Def.gen_relation] and insert all related to relation
|
|
information in the base. *)
|
|
let insert_relation gen ip r =
|
|
{
|
|
r_type = r.r_type;
|
|
r_fath = map_option (insert_relation_parent gen ip Male) r.r_fath;
|
|
r_moth = map_option (insert_relation_parent gen ip Female) r.r_moth;
|
|
r_sources = unique_string gen r.r_sources;
|
|
}
|
|
|
|
(** Insert all information related to the person's relations and add those
|
|
relations to the person's list of related parents. *)
|
|
let insert_relations fname gen sb sex rl =
|
|
(* insert concerned person *)
|
|
let p, ip = insert_somebody gen sb in
|
|
if p.m_rparents <> [] then (
|
|
Printf.printf "\nFile \"%s\"\n" fname;
|
|
Printf.printf "Relations already defined for \"%s%s %s\"\n"
|
|
(sou gen.g_base p.m_first_name)
|
|
(if p.m_occ = 0 then "" else "." ^ string_of_int p.m_occ)
|
|
(sou gen.g_base p.m_surname);
|
|
check_error gen)
|
|
else (
|
|
notice_sex gen p sex;
|
|
let rl = List.map (insert_relation gen ip) rl in
|
|
p.m_rparents <- rl)
|
|
|
|
(** Insert syntax element read from .gwo file. *)
|
|
let insert_syntax fname gen = function
|
|
| Family (cpl, fs, ms, witl, fevents, fam, des) ->
|
|
insert_family gen cpl fs ms witl fevents fam des
|
|
| Notes (key, str) -> insert_notes fname gen key str
|
|
| Relations (sb, sex, rl) -> insert_relations fname gen sb sex rl
|
|
| Pevent (sb, _, pevents) -> insert_pevents fname gen sb pevents
|
|
| Bnotes (nfname, str) -> insert_bnotes fname gen nfname str
|
|
| Wnotes (wizid, str) -> insert_wiznote gen wizid str
|
|
|
|
(** Update person by looking up information inferred from person events *)
|
|
let update_person_with_pevents p =
|
|
let found_birth = ref false in
|
|
let found_baptism = ref false in
|
|
let found_death = ref false in
|
|
let found_burial = ref false in
|
|
let death_std_fields = p.death in
|
|
let death_reason_std_fields =
|
|
match death_std_fields with Death (dr, _) -> dr | _ -> Unspecified
|
|
in
|
|
let rec loop pevents p =
|
|
match pevents with
|
|
| [] -> p
|
|
| evt :: l -> (
|
|
match evt.epers_name with
|
|
| Epers_Birth ->
|
|
if !found_birth then loop l p
|
|
else
|
|
let p =
|
|
{
|
|
p with
|
|
birth = evt.epers_date;
|
|
birth_place = evt.epers_place;
|
|
birth_note = evt.epers_note;
|
|
birth_src = evt.epers_src;
|
|
}
|
|
in
|
|
let () = found_birth := true in
|
|
loop l p
|
|
| Epers_Baptism ->
|
|
if !found_baptism then loop l p
|
|
else
|
|
let p =
|
|
{
|
|
p with
|
|
baptism = evt.epers_date;
|
|
baptism_place = evt.epers_place;
|
|
baptism_note = evt.epers_note;
|
|
baptism_src = evt.epers_src;
|
|
}
|
|
in
|
|
let () = found_baptism := true in
|
|
loop l p
|
|
| Epers_Death ->
|
|
if !found_death then loop l p
|
|
else
|
|
let death =
|
|
match Date.od_of_cdate evt.epers_date with
|
|
| Some d -> Death (death_reason_std_fields, Date.cdate_of_date d)
|
|
| None -> (
|
|
match death_std_fields with
|
|
| OfCourseDead -> OfCourseDead
|
|
| DeadYoung -> DeadYoung
|
|
| _ -> DeadDontKnowWhen)
|
|
in
|
|
let p =
|
|
{
|
|
p with
|
|
death;
|
|
death_place = evt.epers_place;
|
|
death_note = evt.epers_note;
|
|
death_src = evt.epers_src;
|
|
}
|
|
in
|
|
let () = found_death := true in
|
|
loop l p
|
|
| Epers_Burial ->
|
|
if !found_burial then loop l p
|
|
else
|
|
let p =
|
|
{
|
|
p with
|
|
burial = Buried evt.epers_date;
|
|
burial_place = evt.epers_place;
|
|
burial_note = evt.epers_note;
|
|
burial_src = evt.epers_src;
|
|
}
|
|
in
|
|
let () = found_burial := true in
|
|
loop l p
|
|
| Epers_Cremation ->
|
|
if !found_burial then loop l p
|
|
else
|
|
let p =
|
|
{
|
|
p with
|
|
burial = Cremated evt.epers_date;
|
|
burial_place = evt.epers_place;
|
|
burial_note = evt.epers_note;
|
|
burial_src = evt.epers_src;
|
|
}
|
|
in
|
|
let () = found_burial := true in
|
|
loop l p
|
|
| _ -> loop l p)
|
|
in
|
|
loop p.pevents p
|
|
|
|
(** Update person's event list by looking up inferred personal information. *)
|
|
let update_pevents_with_person p =
|
|
let empty_string = 0 in
|
|
let evt_birth =
|
|
match Date.od_of_cdate p.birth with
|
|
| Some _ ->
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Birth;
|
|
epers_date = p.birth;
|
|
epers_place = p.birth_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.birth_note;
|
|
epers_src = p.birth_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| None ->
|
|
if p.birth_place = 0 && p.birth_src = 0 then None
|
|
else
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Birth;
|
|
epers_date = p.birth;
|
|
epers_place = p.birth_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.birth_note;
|
|
epers_src = p.birth_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let evt_bapt =
|
|
match Date.od_of_cdate p.baptism with
|
|
| Some _ ->
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Baptism;
|
|
epers_date = p.baptism;
|
|
epers_place = p.baptism_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.baptism_note;
|
|
epers_src = p.baptism_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| None ->
|
|
if p.baptism_place = 0 && p.baptism_src = 0 then None
|
|
else
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Baptism;
|
|
epers_date = p.baptism;
|
|
epers_place = p.baptism_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.baptism_note;
|
|
epers_src = p.baptism_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let evt_death =
|
|
match p.death with
|
|
| NotDead | DontKnowIfDead ->
|
|
if p.death_place = 0 && p.death_src = 0 then None
|
|
else
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Death;
|
|
epers_date = Date.cdate_None;
|
|
epers_place = p.death_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.death_note;
|
|
epers_src = p.death_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| Death (_, cd) ->
|
|
let date = Date.cdate_of_od (Some (Date.date_of_cdate cd)) in
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Death;
|
|
epers_date = date;
|
|
epers_place = p.death_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.death_note;
|
|
epers_src = p.death_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| DeadYoung | DeadDontKnowWhen | OfCourseDead ->
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Death;
|
|
epers_date = Date.cdate_None;
|
|
epers_place = p.death_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.death_note;
|
|
epers_src = p.death_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let evt_burial =
|
|
match p.burial with
|
|
| UnknownBurial ->
|
|
if p.burial_place = 0 && p.burial_src = 0 then None
|
|
else
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Burial;
|
|
epers_date = Date.cdate_None;
|
|
epers_place = p.burial_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.burial_note;
|
|
epers_src = p.burial_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| Buried cd ->
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Burial;
|
|
epers_date = cd;
|
|
epers_place = p.burial_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.burial_note;
|
|
epers_src = p.burial_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
| Cremated cd ->
|
|
let evt =
|
|
{
|
|
epers_name = Epers_Cremation;
|
|
epers_date = cd;
|
|
epers_place = p.burial_place;
|
|
epers_reason = empty_string;
|
|
epers_note = p.burial_note;
|
|
epers_src = p.burial_src;
|
|
epers_witnesses = [||];
|
|
}
|
|
in
|
|
Some evt
|
|
in
|
|
let pevents = [ evt_birth; evt_bapt; evt_death; evt_burial ] in
|
|
let pevents =
|
|
List.fold_right
|
|
(fun evt pevents ->
|
|
match evt with Some evt -> evt :: pevents | None -> pevents)
|
|
pevents []
|
|
in
|
|
{ p with pevents }
|
|
|
|
(** Returns list of persons from [min_person list] where some absent information
|
|
was extracted from file [per_ic]. Adjusts person with inffered information
|
|
from events or inversely. *)
|
|
let convert_persons per_index_ic per_ic persons =
|
|
Array.mapi
|
|
(fun i mp ->
|
|
let p =
|
|
let c =
|
|
try
|
|
seek_in per_index_ic (sizeof_long * i);
|
|
let pos = input_binary_int per_index_ic in
|
|
seek_in per_ic pos;
|
|
input_char per_ic
|
|
with End_of_file -> 'U'
|
|
in
|
|
match c with
|
|
(* if person is defined read person *)
|
|
| 'D' -> (input_item_value per_ic : person)
|
|
(* if read person is undefined then create dummy person *)
|
|
| 'U' ->
|
|
let empty_string = 0 in
|
|
{
|
|
first_name = empty_string;
|
|
surname = empty_string;
|
|
occ = 0;
|
|
image = empty_string;
|
|
first_names_aliases = [];
|
|
surnames_aliases = [];
|
|
public_name = empty_string;
|
|
qualifiers = [];
|
|
aliases = [];
|
|
titles = [];
|
|
rparents = [];
|
|
related = [];
|
|
occupation = empty_string;
|
|
sex = Neuter;
|
|
access = IfTitles;
|
|
birth = Date.cdate_None;
|
|
birth_place = empty_string;
|
|
birth_note = empty_string;
|
|
birth_src = empty_string;
|
|
baptism = Date.cdate_None;
|
|
baptism_place = empty_string;
|
|
baptism_note = empty_string;
|
|
baptism_src = empty_string;
|
|
death = DontKnowIfDead;
|
|
death_place = empty_string;
|
|
death_note = empty_string;
|
|
death_src = empty_string;
|
|
burial = UnknownBurial;
|
|
burial_place = empty_string;
|
|
burial_note = empty_string;
|
|
burial_src = empty_string;
|
|
pevents = [];
|
|
notes = empty_string;
|
|
psources = empty_string;
|
|
key_index = 0;
|
|
}
|
|
| _ -> assert false
|
|
in
|
|
let p =
|
|
{
|
|
p with
|
|
first_name = mp.m_first_name;
|
|
surname = mp.m_surname;
|
|
occ = mp.m_occ;
|
|
rparents = mp.m_rparents;
|
|
related = mp.m_related;
|
|
pevents = mp.m_pevents;
|
|
sex = mp.m_sex;
|
|
notes = mp.m_notes;
|
|
key_index = i;
|
|
}
|
|
in
|
|
(* Si on a trouvé des évènements, on mets à jour *)
|
|
if p.pevents <> [] then update_person_with_pevents p
|
|
else update_pevents_with_person p)
|
|
persons
|
|
|
|
(** File containing the particles to use *)
|
|
let particules_file = ref ""
|
|
|
|
(** Returns list of particles from the file. If filename is empty string
|
|
then returns default particles list *)
|
|
let input_particles = function
|
|
| "" -> Mutil.default_particles
|
|
| file -> Mutil.input_particles file
|
|
|
|
(** Empty base *)
|
|
let empty_base : cbase =
|
|
{
|
|
c_persons = [||];
|
|
c_ascends = [||];
|
|
c_unions = [||];
|
|
c_families = [||];
|
|
c_couples = [||];
|
|
c_descends = [||];
|
|
c_strings = [||];
|
|
c_bnotes =
|
|
{ nread = (fun _ _ -> ""); norigin_file = ""; efiles = (fun _ -> []) };
|
|
}
|
|
|
|
(** Extract information from the [gen.g_base] and create database *)
|
|
let make_base bname gen per_index_ic per_ic =
|
|
let _ =
|
|
Printf.eprintf "pcnt %d persons %d\n" gen.g_pcnt
|
|
(Array.length gen.g_base.c_persons);
|
|
flush stderr
|
|
in
|
|
(* get full persons information *)
|
|
let persons =
|
|
let a = Array.sub gen.g_base.c_persons 0 gen.g_pcnt in
|
|
gen.g_base.c_persons <- [||];
|
|
convert_persons per_index_ic per_ic a
|
|
in
|
|
let ascends =
|
|
let a = Array.sub gen.g_base.c_ascends 0 gen.g_pcnt in
|
|
gen.g_base.c_ascends <- [||];
|
|
a
|
|
in
|
|
let unions =
|
|
let a = Array.sub gen.g_base.c_unions 0 gen.g_pcnt in
|
|
gen.g_base.c_unions <- [||];
|
|
a
|
|
in
|
|
let _ =
|
|
Printf.eprintf "fcnt %d families %d\n" gen.g_fcnt
|
|
(Array.length gen.g_base.c_couples);
|
|
flush stderr
|
|
in
|
|
let families =
|
|
let a = Array.sub gen.g_base.c_families 0 gen.g_fcnt in
|
|
gen.g_base.c_families <- [||];
|
|
a
|
|
in
|
|
let couples =
|
|
let a = Array.sub gen.g_base.c_couples 0 gen.g_fcnt in
|
|
gen.g_base.c_couples <- [||];
|
|
a
|
|
in
|
|
let descends =
|
|
let a = Array.sub gen.g_base.c_descends 0 gen.g_fcnt in
|
|
gen.g_base.c_descends <- [||];
|
|
a
|
|
in
|
|
let _ =
|
|
Printf.eprintf "scnt %d strings %d\n" gen.g_scnt
|
|
(Array.length gen.g_base.c_strings);
|
|
flush stderr
|
|
in
|
|
let strings =
|
|
let a = Array.sub gen.g_base.c_strings 0 gen.g_scnt in
|
|
gen.g_base.c_strings <- [||];
|
|
a
|
|
in
|
|
Gwdb.make bname
|
|
(input_particles !particules_file)
|
|
( (persons, ascends, unions),
|
|
(families, couples, descends),
|
|
strings,
|
|
gen.g_base.c_bnotes )
|
|
|
|
(** Write content in the file *)
|
|
let write_file_contents fname text =
|
|
let oc = open_out fname in
|
|
output_string oc text;
|
|
close_out oc
|
|
|
|
(** Create and fill a file for every wizard note *)
|
|
let output_wizard_notes bdir wiznotes =
|
|
let wizdir = Filename.concat bdir "wiznotes" in
|
|
if wiznotes <> [] then (
|
|
(* FIXME ad hoc solution. wiznotes should be handled same as notes_d *)
|
|
if not @@ Sys.file_exists wizdir then Unix.mkdir wizdir 0o755;
|
|
List.iter
|
|
(fun (wizid, text) ->
|
|
let fname = Filename.concat wizdir wizid ^ ".txt" in
|
|
write_file_contents fname text)
|
|
wiznotes)
|
|
|
|
(** Create file that contains command used to call this program *)
|
|
let output_command_line bdir =
|
|
let oc = open_out (Filename.concat bdir "command.txt") in
|
|
Printf.fprintf oc "%s" Sys.argv.(0);
|
|
for i = 1 to Array.length Sys.argv - 1 do
|
|
Printf.fprintf oc " %s" Sys.argv.(i)
|
|
done;
|
|
Printf.fprintf oc "\n";
|
|
close_out oc
|
|
|
|
(** Link .gwo files and create a database. *)
|
|
let link next_family_fun bdir =
|
|
let tmp_dir = Filename.concat "gw_tmp" bdir in
|
|
Mutil.mkdir_p tmp_dir;
|
|
let tmp_per_index = Filename.concat tmp_dir "gwc_per_index" in
|
|
let tmp_per = Filename.concat tmp_dir "gwc_per" in
|
|
let tmp_fam_index = Filename.concat tmp_dir "gwc_fam_index" in
|
|
let tmp_fam = Filename.concat tmp_dir "gwc_fam" in
|
|
let fi =
|
|
{
|
|
f_local_names = Hashtbl.create 20011;
|
|
f_curr_src_file = "";
|
|
f_curr_gwo_file = "";
|
|
f_separate = false;
|
|
f_shift = 0;
|
|
f_bnotes = `merge;
|
|
}
|
|
in
|
|
let gen =
|
|
{
|
|
g_strings = Hashtbl.create 20011;
|
|
g_names = Hashtbl.create 20011;
|
|
g_pcnt = 0;
|
|
g_fcnt = 0;
|
|
g_scnt = 0;
|
|
g_file_info = fi;
|
|
g_base = empty_base;
|
|
g_patch_p = Hashtbl.create 20011;
|
|
g_wiznotes = [];
|
|
g_def = [||];
|
|
g_first_av_occ = Hashtbl.create 1;
|
|
g_errored = false;
|
|
g_per_index = open_out_bin tmp_per_index;
|
|
g_per = open_out_bin tmp_per;
|
|
g_fam_index = open_out_bin tmp_fam_index;
|
|
g_fam = open_out_bin tmp_fam;
|
|
}
|
|
in
|
|
let per_index_ic = open_in_bin tmp_per_index in
|
|
let per_ic = open_in_bin tmp_per in
|
|
let istr_empty = unique_string gen "" in
|
|
let istr_quest = unique_string gen "?" in
|
|
assert (istr_empty = 0);
|
|
assert (istr_quest = 1);
|
|
if Sys.unix then Sys.remove tmp_per_index;
|
|
if Sys.unix then Sys.remove tmp_per;
|
|
if Sys.unix then Sys.remove tmp_fam_index;
|
|
if Sys.unix then Sys.remove tmp_fam;
|
|
let next_family = next_family_fun fi in
|
|
(let rec loop () =
|
|
match next_family () with
|
|
| Some fam ->
|
|
insert_syntax fi.f_curr_src_file gen fam;
|
|
loop ()
|
|
| None -> ()
|
|
in
|
|
loop ());
|
|
close_out gen.g_per_index;
|
|
close_out gen.g_per;
|
|
close_out gen.g_fam_index;
|
|
close_out gen.g_fam;
|
|
Hashtbl.clear gen.g_strings;
|
|
Hashtbl.clear gen.g_names;
|
|
Hashtbl.clear fi.f_local_names;
|
|
Gc.compact ();
|
|
let base = make_base bdir gen per_index_ic per_ic in
|
|
Hashtbl.clear gen.g_patch_p;
|
|
if !do_check && gen.g_pcnt > 0 then (
|
|
Check.check_base base (set_error base gen) (set_warning base) ignore;
|
|
if !pr_stats then Stats.(print_stats base @@ stat_base base));
|
|
if not gen.g_errored then (
|
|
if !do_consang then ignore @@ ConsangAll.compute base true;
|
|
Gwdb.sync base;
|
|
output_wizard_notes bdir gen.g_wiznotes;
|
|
Mutil.remove_dir tmp_dir;
|
|
output_command_line bdir;
|
|
true)
|
|
else false
|