350 lines
14 KiB
OCaml
350 lines
14 KiB
OCaml
(* $Id: check.ml,v 5.28 2008-11-03 15:40:10 ddr Exp $ *)
|
|
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Def
|
|
open Gwdb
|
|
|
|
(* Printing check errors *)
|
|
|
|
let designation base p =
|
|
let s = Gutil.designation base p in
|
|
if String.get s 0 = '?' || String.get s (String.length s - 1) = '?' then
|
|
s ^ " (i=" ^ string_of_iper (get_iper p) ^ ")"
|
|
else s
|
|
|
|
let string_of_epers_name base epers_name =
|
|
match epers_name with
|
|
| Epers_Birth -> "birth"
|
|
| Epers_Baptism -> "baptism"
|
|
| Epers_Death -> "death"
|
|
| Epers_Burial -> "burial"
|
|
| Epers_Cremation -> "cremation"
|
|
| Epers_Accomplishment -> "accomplishment"
|
|
| Epers_Acquisition -> "acquisition"
|
|
| Epers_Adhesion -> "adhesion"
|
|
| Epers_BaptismLDS -> "baptism (LDS)"
|
|
| Epers_BarMitzvah -> "bar mitzvah"
|
|
| Epers_BatMitzvah -> "bat mitzvah"
|
|
| Epers_Benediction -> "benediction"
|
|
| Epers_ChangeName -> "change name"
|
|
| Epers_Circumcision -> "circumcision"
|
|
| Epers_Confirmation -> "confirmation"
|
|
| Epers_ConfirmationLDS -> "confirmation (LDS)"
|
|
| Epers_Decoration -> "decoration"
|
|
| Epers_DemobilisationMilitaire -> "military demobilisation"
|
|
| Epers_Diploma -> "diploma"
|
|
| Epers_Distinction -> "distinction"
|
|
| Epers_Dotation -> "dotation"
|
|
| Epers_DotationLDS -> "dotation (LDS)"
|
|
| Epers_Education -> "education"
|
|
| Epers_Election -> "election"
|
|
| Epers_Emigration -> "emigration"
|
|
| Epers_Excommunication -> "excommunication"
|
|
| Epers_FamilyLinkLDS -> "family link (LDS)"
|
|
| Epers_FirstCommunion -> "first communion"
|
|
| Epers_Funeral -> "funeral"
|
|
| Epers_Graduate -> "graduation"
|
|
| Epers_Hospitalisation -> "hospitalisation"
|
|
| Epers_Illness -> "illness"
|
|
| Epers_Immigration -> "immigration"
|
|
| Epers_ListePassenger -> "passenger liste"
|
|
| Epers_MilitaryDistinction -> "military distinction"
|
|
| Epers_MilitaryPromotion -> "military promotion"
|
|
| Epers_MilitaryService -> "military service"
|
|
| Epers_MobilisationMilitaire -> "military mobilisation"
|
|
| Epers_Naturalisation -> "naturalisation"
|
|
| Epers_Occupation -> "occupation"
|
|
| Epers_Ordination -> "ordination"
|
|
| Epers_Property -> "property"
|
|
| Epers_Recensement -> "recensement"
|
|
| Epers_Residence -> "residence"
|
|
| Epers_Retired -> "retirement"
|
|
| Epers_ScellentChildLDS -> "scellent child (LDS)"
|
|
| Epers_ScellentParentLDS -> "scellent parent (LDS)"
|
|
| Epers_ScellentSpouseLDS -> "scellent spouse (LDS)"
|
|
| Epers_VenteBien -> "sell"
|
|
| Epers_Will -> "will"
|
|
| Epers_Name n -> sou base n
|
|
|
|
let string_of_efam_name base efam_name =
|
|
match efam_name with
|
|
| Efam_Marriage -> "marriage"
|
|
| Efam_NoMarriage -> "relation"
|
|
| Efam_NoMention -> "relation"
|
|
| Efam_Engage -> "engagement"
|
|
| Efam_Divorce -> "divorce"
|
|
| Efam_Separated -> "separation"
|
|
| Efam_Annulation -> "annulation"
|
|
| Efam_MarriageBann -> "marriage bann"
|
|
| Efam_MarriageContract -> "marriage contract"
|
|
| Efam_MarriageLicense -> "marriage licence"
|
|
| Efam_PACS -> "PACS"
|
|
| Efam_Residence -> "residence"
|
|
| Efam_Name n -> sou base n
|
|
|
|
let print_base_error oc base = function
|
|
| AlreadyDefined p ->
|
|
Printf.fprintf oc "%s is defined several times\n" (designation base p)
|
|
| OwnAncestor p ->
|
|
Printf.fprintf oc "%s is his/her own ancestor\n" (designation base p)
|
|
| BadSexOfMarriedPerson p ->
|
|
Printf.fprintf oc "%s bad sex for a married person\n" (designation base p)
|
|
|
|
let print_base_warning oc base = function
|
|
| BigAgeBetweenSpouses (p1, p2, a) ->
|
|
Printf.fprintf oc
|
|
"The difference of age between %s and %s is quite important: %d\n"
|
|
(designation base p1) (designation base p2) a.year
|
|
| BirthAfterDeath p ->
|
|
Printf.fprintf oc "%s born after his/her death\n" (designation base p)
|
|
| ChangedOrderOfChildren (ifam, _, _, _) ->
|
|
let cpl = foi base ifam in
|
|
Printf.fprintf oc "Changed order of children of %s and %s\n"
|
|
(designation base (poi base (get_father cpl)))
|
|
(designation base (poi base (get_mother cpl)))
|
|
| ChildrenNotInOrder (ifam, _, elder, x) ->
|
|
let cpl = foi base ifam in
|
|
Printf.fprintf oc
|
|
"The following children of\n %s\nand\n %s\nare not in order:\n"
|
|
(designation base (poi base (get_father cpl)))
|
|
(designation base (poi base (get_mother cpl)));
|
|
Printf.fprintf oc "- %s\n" (designation base elder);
|
|
Printf.fprintf oc "- %s\n" (designation base x)
|
|
| ChangedOrderOfMarriages (p, _, _) ->
|
|
Printf.fprintf oc "Changed order of marriages of %s\n"
|
|
(designation base p)
|
|
| ChangedOrderOfFamilyEvents (ifam, _, _) ->
|
|
let cpl = foi base ifam in
|
|
Printf.fprintf oc "Changed order of family's events for %s\n"
|
|
(designation base (poi base (get_father cpl)));
|
|
Printf.fprintf oc "Changed order of family's events for %s\n"
|
|
(designation base (poi base (get_mother cpl)))
|
|
| ChangedOrderOfPersonEvents (p, _, _) ->
|
|
Printf.fprintf oc "Changed order of person's events for %s\n"
|
|
(designation base p)
|
|
| CloseChildren (ifam, c1, c2) ->
|
|
let cpl = foi base ifam in
|
|
Printf.fprintf oc
|
|
"The following children of\n %s\nand\n %s\nare born very close:\n"
|
|
(designation base (poi base (get_father cpl)))
|
|
(designation base (poi base (get_mother cpl)));
|
|
Printf.fprintf oc "- %s\n" (designation base c1);
|
|
Printf.fprintf oc "- %s\n" (designation base c2)
|
|
| DeadOld (p, a) ->
|
|
Printf.fprintf oc "%s died at the advanced age of %d years old\n"
|
|
(designation base p) a.year
|
|
| DeadTooEarlyToBeFather (father, child) ->
|
|
Printf.fprintf oc "%s " (designation base child);
|
|
Printf.fprintf oc
|
|
"is born more than 2 years after the death of his/her father";
|
|
Printf.fprintf oc " %s\n" (designation base father)
|
|
| DistantChildren (ifam, p1, p2) ->
|
|
let cpl = foi base ifam in
|
|
Printf.fprintf oc
|
|
"The following children of\n %s\nand\n %s\nare born very close:\n"
|
|
(designation base (poi base (get_father cpl)))
|
|
(designation base (poi base (get_mother cpl)));
|
|
Printf.fprintf oc "- %s\n" (designation base p1);
|
|
Printf.fprintf oc "- %s\n" (designation base p2)
|
|
| FEventOrder (p, e1, e2) ->
|
|
Printf.fprintf oc "%s's %s before his/her %s\n" (designation base p)
|
|
(string_of_efam_name base e1.efam_name)
|
|
(string_of_efam_name base e2.efam_name)
|
|
| FWitnessEventAfterDeath (p, e, _fam) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "witnessed the %s after his/her death\n"
|
|
(string_of_efam_name base e.efam_name)
|
|
| FWitnessEventBeforeBirth (p, e, _fam) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "witnessed the %s before his/her birth\n"
|
|
(string_of_efam_name base e.efam_name)
|
|
| IncoherentSex (p, fixed, not_fixed) ->
|
|
Printf.fprintf oc "%s sex not coherent with relations"
|
|
(designation base p);
|
|
if fixed > 0 then
|
|
if not_fixed > 0 then
|
|
Printf.fprintf oc " (fixed in %d of the %d cases)" fixed
|
|
(fixed + not_fixed)
|
|
else Printf.fprintf oc " (fixed)";
|
|
Printf.fprintf oc "\n"
|
|
| IncoherentAncestorDate (anc, p) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc " has a younger ancestor:";
|
|
Printf.fprintf oc " %s\n" (designation base anc)
|
|
| MarriageDateAfterDeath p ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "marriage after his/her death\n"
|
|
| MarriageDateBeforeBirth p ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "marriage before his/her birth\n"
|
|
| MotherDeadBeforeChildBirth (mother, child) ->
|
|
Printf.fprintf oc "%s is born after the death of his/her mother %s\n"
|
|
(designation base child) (designation base mother)
|
|
| ParentBornAfterChild (parent, child) ->
|
|
Printf.fprintf oc "%s born after his/her child %s\n"
|
|
(designation base parent) (designation base child)
|
|
| ParentTooOld (p, a, _) ->
|
|
Printf.fprintf oc "%s was parent at age of %d\n" (designation base p)
|
|
a.year
|
|
| ParentTooYoung (p, a, _) ->
|
|
Printf.fprintf oc "%s was parent at age of %d\n" (designation base p)
|
|
a.year
|
|
| PossibleDuplicateFam (f1, f2) ->
|
|
Printf.fprintf oc "possible duplicate families: %s and %s\n"
|
|
(string_of_ifam f1) (string_of_ifam f2)
|
|
| PossibleDuplicateFamHomonymous (f1, f2, p) ->
|
|
let f = foi base f1 in
|
|
let fath = get_father f in
|
|
let moth = get_mother f in
|
|
let curr, hom =
|
|
if eq_iper fath (get_iper p) then (moth, fath) else (fath, moth)
|
|
in
|
|
Printf.fprintf oc
|
|
"possible duplicate families: %s and %s, %s has unions with several \
|
|
persons named %s\n"
|
|
(string_of_ifam f1) (string_of_ifam f2)
|
|
(designation base (poi base curr))
|
|
(designation base (poi base hom))
|
|
| PEventOrder (p, e1, e2) ->
|
|
Printf.fprintf oc "%s's %s before his/her %s\n" (designation base p)
|
|
(string_of_epers_name base e1.epers_name)
|
|
(string_of_epers_name base e2.epers_name)
|
|
| PWitnessEventAfterDeath (p, e, _origin) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "witnessed the %s after his/her death\n"
|
|
(string_of_epers_name base e.epers_name)
|
|
| PWitnessEventBeforeBirth (p, e, _origin) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "witnessed the %s before his/her birth\n"
|
|
(string_of_epers_name base e.epers_name)
|
|
| TitleDatesError (p, t) ->
|
|
Printf.fprintf oc "%s " (designation base p);
|
|
Printf.fprintf oc "has incorrect title dates as:\n";
|
|
Printf.fprintf oc " %s %s\n" (sou base t.t_ident) (sou base t.t_place)
|
|
| UndefinedSex p ->
|
|
Printf.fprintf oc "Undefined sex for %s\n" (designation base p)
|
|
| YoungForMarriage (p, a, _) | OldForMarriage (p, a, _) ->
|
|
Printf.fprintf oc "%s married at age %d\n" (designation base p) a.year
|
|
|
|
type check_date =
|
|
| CheckBefore of int
|
|
| CheckAfter of int
|
|
| CheckOther of int
|
|
| CheckInfered of check_date
|
|
|
|
let min_year_of p =
|
|
let aux = function
|
|
| { prec = After; year } -> CheckAfter year
|
|
| { prec = Before; year } -> CheckBefore year
|
|
| { year } -> CheckOther year
|
|
in
|
|
Option.map aux (Date.cdate_to_dmy_opt (get_birth p))
|
|
|
|
let dummy_date = CheckInfered (CheckOther max_int)
|
|
|
|
(* check ad print warning if ancestors is born before person *)
|
|
let rec check_ancestors base warning year year_tab ip ini_p =
|
|
let infer = function
|
|
| CheckBefore i -> CheckInfered (CheckBefore (pred i))
|
|
| CheckAfter i -> CheckInfered (CheckAfter (pred i))
|
|
| CheckOther i -> CheckInfered (CheckOther (pred i))
|
|
| CheckInfered (CheckBefore i) -> CheckInfered (CheckBefore (pred i))
|
|
| CheckInfered (CheckAfter i) -> CheckInfered (CheckAfter (pred i))
|
|
| CheckInfered (CheckOther i) -> CheckInfered (CheckOther (pred i))
|
|
| _ -> assert false
|
|
in
|
|
let own = function CheckInfered _ -> false | _ -> true in
|
|
let test a b p p' =
|
|
match (a, b) with
|
|
| ( CheckAfter y,
|
|
( CheckBefore y'
|
|
| CheckOther y'
|
|
| CheckInfered (CheckBefore y')
|
|
| CheckInfered (CheckOther y') ) )
|
|
when y >= y' ->
|
|
warning (IncoherentAncestorDate (Lazy.force p, p'))
|
|
| _ -> ()
|
|
in
|
|
if Gwdb.Marker.get year_tab ip = dummy_date then (
|
|
let p = poi base ip in
|
|
let new_year, new_ini_p =
|
|
match min_year_of p with Some y -> (y, p) | None -> (infer year, ini_p)
|
|
in
|
|
Gwdb.Marker.set year_tab ip new_year;
|
|
test new_year year (lazy p) ini_p;
|
|
match get_parents p with
|
|
| Some ifam ->
|
|
let fam = foi base ifam in
|
|
let f ip =
|
|
let year = Gwdb.Marker.get year_tab ip in
|
|
if year = dummy_date then
|
|
check_ancestors base warning new_year year_tab ip new_ini_p
|
|
else if own year then
|
|
test year new_year (lazy (poi base ip)) new_ini_p
|
|
in
|
|
f @@ get_father fam;
|
|
f @@ get_mother fam
|
|
| None -> ())
|
|
|
|
let check_base ?(verbose = false) ?(mem = false) base error warning changed_p =
|
|
if not mem then (
|
|
Gwdb.load_persons_array base;
|
|
Gwdb.load_ascends_array base;
|
|
Gwdb.load_unions_array base;
|
|
Gwdb.load_couples_array base);
|
|
let persons = Gwdb.ipers base in
|
|
let len = Gwdb.Collection.length persons in
|
|
let year_tab = Gwdb.iper_marker (Gwdb.ipers base) dummy_date in
|
|
if verbose then (
|
|
Printf.eprintf "check persons\n";
|
|
ProgrBar.start ();
|
|
Gwdb.Collection.iteri
|
|
(fun i ip ->
|
|
ProgrBar.run i len;
|
|
let p = poi base ip in
|
|
if Gwdb.Marker.get year_tab ip = dummy_date then
|
|
check_ancestors base warning dummy_date year_tab ip p;
|
|
match CheckItem.person ~onchange:false base warning p with
|
|
| Some ippl -> List.iter changed_p ippl
|
|
| None -> ())
|
|
persons;
|
|
ProgrBar.finish ())
|
|
else
|
|
Gwdb.Collection.iter
|
|
(fun ip ->
|
|
let p = poi base ip in
|
|
if Gwdb.Marker.get year_tab ip = dummy_date then
|
|
check_ancestors base warning dummy_date year_tab ip p;
|
|
match CheckItem.person ~onchange:false base warning p with
|
|
| Some ippl -> List.iter changed_p ippl
|
|
| None -> ())
|
|
persons;
|
|
if not mem then (
|
|
Gwdb.clear_unions_array base;
|
|
Gwdb.load_families_array base;
|
|
Gwdb.load_descends_array base);
|
|
let families = Gwdb.ifams base in
|
|
let len = Gwdb.Collection.length families in
|
|
if verbose then (
|
|
Printf.eprintf "check families\n";
|
|
ProgrBar.start ();
|
|
Gwdb.Collection.iteri
|
|
(fun i ifam ->
|
|
ProgrBar.run i len;
|
|
CheckItem.family ~onchange:false base warning ifam @@ foi base ifam)
|
|
families;
|
|
ProgrBar.finish ())
|
|
else
|
|
Gwdb.Collection.iter
|
|
(fun ifam ->
|
|
CheckItem.family ~onchange:false base warning ifam @@ foi base ifam)
|
|
families;
|
|
if not mem then (
|
|
Gwdb.clear_persons_array base;
|
|
Gwdb.clear_families_array base;
|
|
Gwdb.clear_descends_array base);
|
|
Consang.check_noloop base error;
|
|
if not mem then (
|
|
Gwdb.clear_ascends_array base;
|
|
Gwdb.clear_couples_array base)
|