1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935
|
(* $Id: checkItem.ml,v 1.11 2007-09-05 13:16:45 ddr Exp $ *)
(* Copyright (c) 2006-2007 INRIA *)
open Def;
open Gwdb;
type base_error = error person;
type base_warning = warning person family title;
type base_misc = misc person family title;
(* Constants used for computing the warnings. *)
value max_age_btw_cpl = 50;
value max_days_btw_sibl = 10;
value max_month_btw_sibl = 7;
value lim_date_death = 1900;
value max_death_after_lim_date_death = 105;
value max_death_before_lim_date_death = 100;
value min_parent_age = 11;
value max_father_age = 70;
value max_mother_age = 55;
value lim_date_marriage = 1850;
value min_age_marriage = 13;
value average_marriage_age = 20;
value common_prec p1 p2 =
if p1 = p2 then p1
else
match (p1, p2) with
[ (Sure, _) -> p2
| (_, Sure) -> p1
| _ -> Maybe ]
;
value leap_year a =
if a mod 100 = 0 then a / 100 mod 4 = 0 else a mod 4 = 0
;
value nb_days_in_month =
let tb = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] in
fun m a ->
if m = 2 && leap_year a then 29
else if m >= 1 && m <= 12 then tb.(m - 1)
else 0
;
value time_elapsed d1 d2 =
let prec = common_prec d1.prec d2.prec in
match d1 with
[ {day = 0; month = 0; year = a1} ->
{day = 0; month = 0; year = d2.year - a1; prec = prec; delta = 0}
| {day = 0; month = m1; year = a1} ->
match d2 with
[ {day = 0; month = 0; year = a2} ->
{day = 0; month = 0; year = a2 - a1; prec = prec; delta = 0}
| {day = 0; month = m2; year = a2} ->
let r = 0 in
let (month, r) =
if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1)
in
let year = a2 - a1 - r in
{day = 0; month = month; year = year; prec = prec; delta = 0}
| {day = j2; month = m2; year = a2} ->
let r = 0 in
let (month, r) =
if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1)
in
let year = a2 - a1 - r in
{day = 0; month = month; year = year; prec = prec; delta = 0} ]
| {day = j1; month = m1; year = a1} ->
match d2 with
[ {day = 0; month = 0; year = a2} ->
{day = 0; month = 0; year = a2 - a1; prec = prec; delta = 0}
| {day = 0; month = m2; year = a2} ->
let r = 0 in
let (month, r) =
if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1)
in
let year = a2 - a1 - r in
{day = 0; month = month; year = year; prec = prec; delta = 0}
| {day = j2; month = m2; year = a2} ->
let (day, r) =
if j1 <= j2 then (j2 - j1, 0)
else (j2 - j1 + nb_days_in_month m1 a1, 1)
in
let (month, r) =
if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1)
in
let year = a2 - a1 - r in
{day = day; month = month; year = year; prec = prec; delta = 0} ] ]
;
value strictly_before_dmy d1 d2 =
let {day = d; month = m; year = y; prec = p} = time_elapsed d2 d1 in
if y < 0 then True
else if y > 0 then False
else if m < 0 then True
else if m > 0 then False
else if d < 0 then True
else if d > 0 then False
else if d1.prec = d2.prec then False
else if d1.prec = Before && d2.prec = After then True
else False
;
value strictly_before d1 d2 =
match (d1, d2) with
[ (Dgreg d1 _, Dgreg d2 _) -> strictly_before_dmy d1 d2
| _ -> False ]
;
value strictly_after_dmy d1 d2 =
let {day = d; month = m; year = y; prec = p} = time_elapsed d1 d2 in
if y < 0 then True
else if y > 0 then False
else if m < 0 then True
else if m > 0 then False
else if d < 0 then True
else if d > 0 then False
else if d2.prec = d1.prec then False
else if d2.prec = Before && d1.prec = After then True
else False
;
value strictly_after d1 d2 =
match (d1, d2) with
[ (Dgreg d1 _, Dgreg d2 _) -> strictly_after_dmy d1 d2
| _ -> False ]
;
(* ********************************************************************** *)
(* [Fonc] compare_date : date -> date -> int *)
(** [Description] : Fonction de comparaison de deux dates. On ne tiens
pas compte de la précision de la date. (Fonction
identique à Date.ml)
[Args] :
- d1 : la première date
- d2 : la deuxième date
[Retour] : int
[Rem] : Non exporté en clair hors de ce module. *)
(* ********************************************************************** *)
value compare_date d1 d2 =
match (d1, d2) with
[ (Dgreg dmy1 _, Dgreg dmy2 _) ->
match Pervasives.compare dmy1.year dmy2.year with
[ 0 ->
match Pervasives.compare dmy1.month dmy2.month with
[ 0 ->
(* Si l'une des deux dates n'est pas complète (mois ou jour *)
(* égal à zéro), alors on ne distingue pas les deux dates. *)
if dmy1.day = 0 || dmy2.day = 0 then 0
else Pervasives.compare dmy1.day dmy2.day
| x ->
(* Idem ci-dessus. *)
if dmy1.month = 0 || dmy2.month = 0 then 0
else x ]
| x -> x]
| (Dgreg dmy1 _, Dtext _) -> 1
| (Dtext _, Dgreg dmy2 _) -> -1
| (Dtext _, Dtext _) -> 0 ]
;
value date_of_death =
fun
[ Death _ cd -> Some (Adef.date_of_cdate cd)
| _ -> None ]
;
value birth_before_death base warning p =
match (Adef.od_of_codate (get_birth p), get_death p) with
[ (Some d1, Death _ d2) ->
let d2 = Adef.date_of_cdate d2 in
if strictly_after d1 d2 then warning (BirthAfterDeath p) else ()
| _ -> () ]
;
value titles_after_birth base warning p t =
let t_date_start = Adef.od_of_codate t.t_date_start in
let t_date_end = Adef.od_of_codate t.t_date_end in
do {
match (t_date_start, t_date_end) with
[ (Some d1, Some d2) ->
if strictly_after d1 d2 then warning (TitleDatesError p t) else ()
| _ -> () ];
match Adef.od_of_codate (get_birth p) with
[ Some d1 ->
do {
match t_date_start with
[ Some d ->
if strictly_after d1 d then warning (TitleDatesError p t)
else ()
| None -> () ];
match t_date_end with
[ Some d ->
if strictly_after d1 d then warning (TitleDatesError p t)
else ()
| None -> () ];
()
}
| _ -> () ];
}
;
value today =
let utm = Unix.time () in
let tm = Unix.localtime utm in
{day = tm.Unix.tm_mday; month = succ tm.Unix.tm_mon;
year = tm.Unix.tm_year + 1900; prec = Sure; delta = 0}
;
value check_person_age base warning p =
(* On pourrait faire un calcul sur la descendance ou l'ascendance si *)
(* on ne trouve rien ... mais c'est peut être un peu trop gourmand *)
(* juste pour un warning ? *)
let first_found_date =
match
(Adef.od_of_codate (get_birth p), Adef.od_of_codate (get_baptism p))
with
[ (Some (Dgreg d _), _) -> Some d
| (_, Some (Dgreg d _)) -> Some d
| _ ->
let rec loop i =
if i >= Array.length (get_family p) then None
else
let fam = foi base (get_family p).(i) in
match Adef.od_of_codate (get_marriage fam) with
[ Some (Dgreg d _) ->
let d = {(d) with year = d.year - average_marriage_age} in
Some d
| _ -> loop (i + 1) ]
in
loop 0 ]
in
let is_dead =
match get_death p with
[ Death _ _ | DeadYoung | DeadDontKnowWhen -> True
| OfCourseDead -> True (* Cas spécial. *)
| _ -> False ]
in
if is_dead then
match (first_found_date, date_of_death (get_death p)) with
[ (Some d1, Some (Dgreg d2 _)) ->
let a = time_elapsed d1 d2 in
if d2.year > lim_date_death then
if a.year > max_death_after_lim_date_death then
warning (DeadOld p a)
else ()
else
if a.year > max_death_before_lim_date_death then
warning (DeadOld p a)
else ()
| _ -> () ]
else ()
;
value try_to_fix_relation_sex base warning p_ref = do {
let p_index = Some (get_key_index p_ref) in
let fixed = ref 0 in
let not_fixed = ref 0 in
let changed_related =
List.fold_right
(fun ip changed_related ->
let p = poi base ip in
let (rparents, changed, not_changed) =
List.fold_right
(fun rel (rparents, changed, not_changed) ->
let (rel, changed, not_changed) =
match (p_index = rel.r_fath, p_index = rel.r_moth) with
[ (True, False) ->
if get_sex p_ref = Female then
match rel.r_moth with
[ Some ip ->
let oth_p = poi base ip in
if get_sex oth_p = Male then
let rel =
{(rel) with
r_fath = rel.r_moth; r_moth = p_index}
in
(rel, changed + 1, not_changed)
else
(rel, changed, not_changed + 1)
| None ->
let rel =
{(rel) with r_fath = None; r_moth = p_index}
in
(rel, changed + 1, not_changed) ]
else (rel, changed, not_changed)
| (False, True) ->
if get_sex p_ref = Male then
match rel.r_fath with
[ Some ip ->
let oth_p = poi base ip in
if get_sex oth_p = Female then
let rel =
{(rel) with
r_moth = rel.r_fath; r_fath = p_index}
in
(rel, changed + 1, not_changed)
else
(rel, changed, not_changed + 1)
| None ->
let rel =
{(rel) with r_moth = None; r_fath = p_index}
in
(rel, changed + 1, not_changed) ]
else (rel, changed, not_changed)
| (False, False) -> (rel, changed, not_changed)
| (True, True) -> (rel, changed, not_changed + 1) ]
in
([rel :: rparents], changed, not_changed))
(get_rparents p) ([], 0, 0)
in
let _ = do {
fixed.val := fixed.val + changed;
not_fixed.val := not_fixed.val + not_changed
}
in
if changed > 0 then [(ip, p, None, Some rparents) :: changed_related]
else changed_related)
(get_related p_ref) []
in
warning (IncoherentSex p_ref fixed.val not_fixed.val);
if fixed.val > 0 then Some changed_related else None
};
value related_sex_is_coherent base warning p_ref =
let p_index = Some (get_key_index p_ref) in
let merge_sex g1 g2 =
match (g1, g2) with
[ (Some Male, Some Male) -> Some Male
| (Some Female, Some Female) -> Some Female
| (Some Neuter, Some g) -> Some g
| (Some g, Some Neuter) -> Some g
| _ -> None ]
in
let check_sex sex rparents =
List.fold_left
(fun g rel ->
match (p_index = rel.r_fath, p_index = rel.r_moth) with
[ (True, False) -> merge_sex g (Some Male)
| (False, True) -> merge_sex g (Some Female)
| (False, False) -> g
| (True, True) -> None ])
sex rparents
in
let new_sex =
List.fold_left
(fun g ip ->
let p = poi base ip in
check_sex g (get_rparents p))
(Some (get_sex p_ref)) (get_related p_ref)
in
match new_sex with
[ Some g ->
if get_sex p_ref != g then
Some [(get_key_index p_ref, p_ref, Some g, None)]
else None
| None -> try_to_fix_relation_sex base warning p_ref ]
;
value check_difference_age_between_cpl base warning ifath imoth =
let fath = poi base ifath in
let moth = poi base imoth in
let find_date p =
match
(Adef.od_of_codate (get_birth p), Adef.od_of_codate (get_baptism p))
with
[ (Some (Dgreg d _), _) -> Some d
| (_, Some (Dgreg d _)) -> Some d
| _ -> None ]
in
match (find_date fath, find_date moth) with
[ (Some d1, Some d2) ->
let a = time_elapsed d1 d2 in
if a.year > max_age_btw_cpl then
warning (BigAgeBetweenSpouses fath moth a)
else ()
| _ -> () ]
;
value year_of d = d.year;
value check_normal_marriage_date_for_someone base error warning witn fam ip =
let p = poi base ip in
match Adef.od_of_codate (get_marriage fam) with
[ Some (Dgreg g2 _ as d2) ->
do {
match Adef.od_of_codate (get_birth p) with
[ Some (Dgreg g1 _ as d1) ->
if strictly_before d2 d1 then
if witn then warning (WitnessDateBeforeBirth p)
else warning (MarriageDateBeforeBirth p)
else if not witn && year_of g2 > lim_date_marriage &&
year_of (time_elapsed g1 g2) < min_age_marriage
then
warning (YoungForMarriage p (time_elapsed g1 g2))
else ()
| _ -> () ];
match get_death p with
[ Death _ d3 ->
let d3 = Adef.date_of_cdate d3 in
if strictly_after d2 d3 then
if witn then warning (WitnessDateAfterDeath p)
else warning (MarriageDateAfterDeath p)
else ()
| _ -> () ];
}
| _ -> () ]
;
(* ************************************************************************* *)
(* [Fonc] check_normal_marriage_date_for_witness :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
(ifam * family) -> unit *)
(** [Description] : Vérifie les dates des témoins par rapport à la date du
mariage.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- ifam : ifam
- family : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_normal_marriage_date_for_witness base error warning (ifam, fam) =
let wl = foi base ifam in
List.iter
(fun ip ->
check_normal_marriage_date_for_someone base error warning True fam ip)
(Array.to_list (get_witnesses wl))
;
(* ************************************************************************* *)
(* [Fonc] check_normal_marriage_date_for_parent :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
(ifam * family) -> unit *)
(** [Description] : Vérifie les dates du conjoint1 et du conjoint2 par
rapport à la date du mariage.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- ifam : ifam
- family : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_normal_marriage_date_for_parent base error warning (ifam, fam) =
do {
let cpl = foi base ifam in
check_normal_marriage_date_for_someone base error warning False fam
(get_father cpl);
check_normal_marriage_date_for_someone base error warning False fam
(get_mother cpl);
check_difference_age_between_cpl base warning
(get_father cpl) (get_mother cpl)
}
;
(*
* Semi sort children by birth dates.
* If all children have birth dates, no problem.
* Otherwise, sorting groups of consecutive children who have dates.
* In not possible cases, try to keep order of children of same sex.
* ex: G1, B2 being resp. girl and boy with date(G1) < date(B2)
* and G and B begin resp. girls boys without dates
* if order is ... B2 B B B G1 ... it becomes ... G1 B2 B B B ...
* if order is ... B2 G G G G1 ... it becomes ... G G G G1 B2 ...
* if order is ... B2 G B G G1 ... no change (a warning appears).
*)
value semi_sort base a before comp di =
loop where rec loop i =
if i < 0 || i >= Array.length a then ()
else
let p1 = poi base a.(i) in
let d1 =
match Adef.od_of_codate (get_birth p1) with
[ Some d1 -> Some d1
| None -> Adef.od_of_codate (get_baptism p1) ]
in
match d1 with
[ Some d1 ->
loop_j None (i - di) where rec loop_j sex_interm_sib j =
if j < 0 || j >= Array.length a then loop (i + di)
else
let p2 = poi base a.(j) in
let d2 =
match Adef.od_of_codate (get_birth p2) with
[ Some d2 -> Some d2
| None -> Adef.od_of_codate (get_baptism p2) ]
in
match d2 with
[ Some d2 ->
if comp d1 d2 then do {
let j =
match sex_interm_sib with
[ Some s ->
if s = get_sex p1 then None
else if s = get_sex p2 then Some j
else None
| None -> Some j ]
in
match j with
[ Some j ->
let k =
loop_k (j - di) where rec loop_k k =
if k < 0 || k >= Array.length a then k + di
else
let p3 = poi base a.(k) in
let d3 =
match Adef.od_of_codate (get_birth p3) with
[ Some d3 -> Some d3
| None -> Adef.od_of_codate (get_baptism p3) ]
in
match d3 with
[ Some d3 ->
if comp d1 d3 then loop_k (k - di)
else k + di
| None -> k + di ]
in
do {
match before.val with
[ Some _ -> ()
| None -> before.val := Some (Array.copy a) ];
let ip = a.(i) in
loop_up i where rec loop_up j =
if j = k then ()
else do {
a.(j) := a.(j - di);
loop_up (j - di)
};
a.(k) := ip;
loop (i + di)
}
| None -> loop (i + di) ]
}
else loop (i + di)
| None ->
match sex_interm_sib with
[ Some s ->
if s = get_sex p2 then loop_j sex_interm_sib (j - di)
else loop (i + di)
| None -> loop_j (Some (get_sex p2)) (j - di) ] ]
| None -> loop (i + di) ]
;
value sort_children base children = do {
let before = ref None in
semi_sort base children before strictly_before 1 1;
semi_sort base children before strictly_after ~-1 1;
semi_sort base children before strictly_before 1 1;
match before.val with
[ Some b -> Some (b, children)
| None -> None ]
};
value sort_children2 base warning ifam des =
let b = get_children des in
match sort_children base b with
[ None -> b
| Some (b, a) -> do {
warning (ChangedOrderOfChildren ifam des b a);
a
} ]
;
(* ********************************************************************** *)
(* [Fonc] check_marriages_order :
base -> (Def.warning -> unit) -> person -> unit *)
(** [Description] : Trie les famillies en fonction des dates de mariages.
[Args] :
- base : base de donnée
- warning : fonction qui ajoute un warning à la liste des warnings
- p : person
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ********************************************************************** *)
value check_marriages_order base warning p = do {
let b = Array.copy (get_family p) in
(* Astuce : on construire un tableau identique à la famille dans *)
(* lequel on remplace toutes les dates inconnues par la dernière *)
(* date maximale que l'on ait vu. *)
(* Exemple : Ma (mariage sans date), et M3 après M1 *)
(* ordre initial Ma M5 Mb M3 M1 ... devient Ma M1 M3 M5 Mb *)
let (_, a) =
Array.fold_left
(fun (max_date, tab) ifam ->
let fam = foi base ifam in
let date =
match Adef.od_of_codate (get_marriage fam) with
[ Some d -> Some d
| None -> max_date ]
in
let max_date =
match (date, max_date) with
[ (Some d1, Some d2) ->
if compare_date d1 d2 = 1 then Some d1
else Some d2
| (Some d1, None) -> Some d1
| _ -> max_date ]
in
(max_date, Array.append tab [| (ifam, date) |]))
(None, [| |]) (get_family p)
in
Array.stable_sort
(fun (f1, d1) (f2, d2) ->
match (d1, d2) with
[ (Some d1, Some d2) -> compare_date d1 d2
| _ -> 0 ] )
a;
let a = Array.map (fun (f, _) -> f) a in
if a <> b then do {
warning (ChangedOrderOfMarriages p b a);
let rec loop i fam =
if i = Array.length fam then ()
else do { fam.(i) := a.(i); loop (i + 1) fam }
in loop 0 (get_family p) }
else ()
};
value close_siblings base error warning x np ifam des =
match (np, Adef.od_of_codate (get_birth x)) with
[ (None, _) -> ()
| (Some (elder, d1), Some d2) ->
match (d1, d2) with
[ (Dgreg d1 _, Dgreg d2 _) ->
let d = time_elapsed d1 d2 in
(* On vérifie les jumeaux ou naissances proches. *)
if d.year = 0 && d.month = 0 && d.day < max_days_btw_sibl then ()
else if d.year = 0 && d.month < max_month_btw_sibl then
warning (CloseChildren ifam des elder x)
else ()
| _ -> () ]
| _ -> () ]
;
value born_after_his_elder_sibling base error warning x np ifam des =
match (np, Adef.od_of_codate (get_birth x), get_death x) with
[ (None, _, _) -> ()
| (Some (elder, d1), Some d2, _) ->
if strictly_after d1 d2 then
warning (ChildrenNotInOrder ifam des elder x)
else ()
| (Some (elder, d1), _, Death _ d2) ->
let d2 = Adef.date_of_cdate d2 in
if strictly_after d1 d2 then
warning (ChildrenNotInOrder ifam des elder x)
else ()
| _ -> () ]
;
value child_born_after_his_parent base error warning x iparent =
let parent = poi base iparent in
match
(Adef.od_of_codate (get_birth parent), Adef.od_of_codate (get_birth x),
date_of_death (get_death x))
with
[ (Some (Dgreg g1 _ as d1), Some (Dgreg g2 _ as d2), _) ->
if strictly_after d1 d2 then warning (ParentBornAfterChild parent x)
else
let a = time_elapsed g1 g2 in
if year_of a < min_parent_age then warning (ParentTooYoung parent a)
else if (get_sex parent = Female && year_of a > max_mother_age) ||
(get_sex parent = Male && year_of a > max_father_age)
then
warning (ParentTooOld parent a)
else ()
| (Some (Dgreg g1 _ as d1), _, Some (Dgreg g2 _ as d2)) ->
if strictly_after d1 d2 then warning (ParentBornAfterChild parent x)
else
let a = time_elapsed g1 g2 in
if year_of a < min_parent_age then warning (ParentTooYoung parent a)
else ()
| _ -> () ]
;
value child_born_before_mother_death base warning x imoth =
let mother = poi base imoth in
match (Adef.od_of_codate (get_birth x), get_death mother) with
[ (Some d1, Death _ d2) ->
let d2 = Adef.date_of_cdate d2 in
if strictly_after d1 d2 then
warning (MotherDeadAfterChildBirth mother x)
else ()
| _ -> () ]
;
value possible_father base warning x ifath =
let father = poi base ifath in
match
(Adef.od_of_codate (get_birth x), date_of_death (get_death father))
with
[ (Some (Dgreg {prec = Before} _), _) |
(_, Some (Dgreg {prec = After} _)) ->
()
| (Some (Dgreg d1 _), Some (Dgreg d2 _)) ->
let a2 =
match d2 with
[ {prec = YearInt a2} -> a2
| {prec = OrYear a2} -> a2
| {year = a} -> a ]
in
if year_of d1 > a2 + 1 then warning (DeadTooEarlyToBeFather father x)
else ()
| _ -> () ]
;
value child_has_sex warning child =
if get_sex child = Neuter then warning (UndefinedSex child) else ()
;
(* ************************************************************************* *)
(* [Fonc] check_marriage_sex :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
(ifam * family) -> unit *)
(** [Description] : Vérifie le sex du couple et s'il est correct la date de
naissance par rapport à la date de décès.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- family : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_marriage_sex base error warning fam =
let cpl = fam in
let fath = poi base (get_father cpl) in
let moth = poi base (get_mother cpl) in
do {
match get_sex fath with
[ Male -> birth_before_death base warning fath
| Female | Neuter ->
if get_relation fam = NoSexesCheckNotMarried
|| get_relation fam = NoSexesCheckMarried then ()
else error (BadSexOfMarriedPerson fath) ];
match get_sex moth with
[ Female -> birth_before_death base warning moth
| Male | Neuter ->
if get_relation fam = NoSexesCheckNotMarried ||
get_relation fam = NoSexesCheckMarried then ()
else error (BadSexOfMarriedPerson moth) ]
};
(* ************************************************************************* *)
(* [Fonc] check_children :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
(ifam * family) -> unit *)
(** [Description] : Vérifie toutes les informations des enfants d'une famille.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- ifam : ifam
- family : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_children base error warning (ifam, fam) =
let cpl = fam in
let des = fam in
let after = sort_children2 base warning ifam des in
let _ =
List.fold_left
(fun np child ->
let child = poi base child in
do {
birth_before_death base warning child;
born_after_his_elder_sibling base error warning child np ifam
des;
close_siblings base error warning child np ifam des;
child_born_after_his_parent base error warning child
(get_father cpl);
child_born_after_his_parent base error warning child
(get_mother cpl);
child_born_before_mother_death base warning child
(get_mother cpl);
possible_father base warning child (get_father cpl);
child_has_sex warning child;
match Adef.od_of_codate (get_birth child) with
[ Some d -> Some (child, d)
| _ -> np ]
})
None (Array.to_list after)
in
()
;
value has_family_sources fam =
not (is_empty_string (get_fsources fam)
&& is_empty_string (get_marriage_src fam))
;
value has_person_sources p =
not (is_empty_string (get_psources p)
&& is_empty_string (get_baptism_src p)
&& is_empty_string (get_birth_src p)
&& is_empty_string (get_death_src p)
&& is_empty_string (get_burial_src p))
;
(* ************************************************************************* *)
(* [Fonc] check_sources :
base -> (Def.misc -> unit) -> ifam -> family -> unit *)
(** [Description] : Il y a un avertissment 'miscellaneous' si aucune des
personnes (conjoint1 ET conjoint2) n'a de sources
(indiduelles ou familliales).
[Args] :
- base : base
- misc : fonction qui ajoute un misc à la liste des miscs
- ifam : ifam
- fam : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_sources base misc ifam fam =
if has_family_sources fam then ()
else
let cpl = foi base ifam in
let fath = poi base (get_father cpl) in
let moth = poi base (get_mother cpl) in
if has_person_sources fath && has_person_sources moth then ()
else misc MissingSources
;
(* main *)
(* ************************************************************************* *)
(* [Fonc] person : base -> (Def.warning -> unit) -> person -> unit *)
(** [Description] : Vérifie les warnings d'une personne à la validation du
formulaire individu.
[Args] :
- base : base
- warning : fonction qui ajoute un warning à la liste des warnings
- p : person
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value person base warning p = do {
birth_before_death base warning p;
check_person_age base warning p;
List.iter (titles_after_birth base warning p) (get_titles p);
related_sex_is_coherent base warning p;
};
(* ************************************************************************* *)
(* [Fonc] family :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
ifam -> family -> unit *)
(** [Description] : En cas de modification d'une famille, on vérifie toutes
les personnes accessibles après la validation du
formulaire (famille).
Vérifie s'il y a des erreurs ou des warnings pour le
couple, les parents du couple, les témoins et les enfants
du couple.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- ifam : ifam
- fam : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value family base error warning ifam fam =
do {
check_marriage_sex base error warning fam;
check_normal_marriage_date_for_parent base error warning (ifam, fam);
check_normal_marriage_date_for_witness base error warning (ifam, fam);
check_children base error warning (ifam, fam);
let father = poi base (get_father fam) in
let mother = poi base (get_mother fam) in
check_marriages_order base warning father;
check_marriages_order base warning mother;
}
;
(* ************************************************************************* *)
(* [Fonc] reduce_family :
base -> (Def.error -> unit) -> (Def.warning -> unit) ->
ifam -> family -> unit *)
(** [Description] : En cas de modification d'une personne, on ne vérifie que
les personnes accessibles après la validation du
formulaire (individu).
Vérifie s'il y a des erreurs ou des warnings pour le
couple, les parents du couple et les enfants du couple.
[Args] :
- base : base
- error : fonction qui ajoute une erreur à la liste des erreurs
- warning : fonction qui ajoute un warning à la liste des warnings
- ifam : ifam
- fam : family
[Retour] : Néant
[Rem] : Non exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value reduce_family base error warning ifam fam =
do {
check_marriage_sex base error warning fam;
check_normal_marriage_date_for_parent base error warning (ifam, fam);
check_children base error warning (ifam, fam)
}
;
(* ************************************************************************* *)
(* [Fonc] check_other_fields :
base -> (Def.misc -> unit) -> ifam -> family -> unit *)
(** [Description] : Vérifie les autres champs de saisie des formulaires
individu et famille.
[Args] :
- base : base
- misc : fonction qui ajoute un misc à la liste des miscs
- ifam : ifam
- fam : family
[Retour] : Néant
[Rem] : Exporté en clair hors de ce module. *)
(* ************************************************************************* *)
value check_other_fields base misc ifam fam =
do {
check_sources base misc ifam fam
}
;
|