1(* $Id: gwdiff.ml,v 5.0 2005-12-13 11:51:26 ddr Exp $ *) 2(* Copyright (c) 2001 Ludovic LEDIEU *) 3 4open Def; 5open Gutil; 6 7(*= TODO ===================================================================== 8 - Improve the way not to check several time the same persons. 9=========================================================================== *) 10 11value in_file1 = ref ""; 12value in_file2 = ref ""; 13value html = ref False; 14value root = ref ""; 15value cr = ref ""; 16 17type messages = 18 [ MsgBadChild of iper 19 | MsgBirthDate 20 | MsgBirthPlace 21 | MsgChildMissing of iper 22 | MsgChildren of iper 23 | MsgDeathDate 24 | MsgDeathPlace 25 | MsgDivorce 26 | MsgFirstName 27 | MsgOccupation 28 | MsgParentsMissing 29 | MsgMarriageDate 30 | MsgMarriagePlace 31 | MsgSex 32 | MsgSpouseMissing of iper 33 | MsgSpouses of iper 34 | MsgSurname ] 35; 36 37value person_string base iper = 38 let p = poi base iper in 39 let fn = sou base p.first_name in 40 let sn = sou base p.surname in 41 if sn = "?" || fn = "?" then 42 fn ^ " " ^ sn ^ " (#" ^ string_of_int (Adef.int_of_iper iper) ^ ")" 43 else fn ^ "." ^ (string_of_int p.occ) ^ " " ^ sn 44; 45 46value person_link bname base iper target = 47 if html.val then 48 Printf.sprintf "<A HREF=\"%s%s_w?i=%d\" TARGET=\"%s\">%s</A>" 49 root.val bname (Adef.int_of_iper iper) target (person_string base iper) 50 else 51 person_string base iper 52; 53 54value print_message base1 base2 msg = 55 do { 56 Printf.printf " "; 57 match msg with 58 [ MsgBadChild iper1 -> 59 Printf.printf "can not isolate one child match: %s" 60 (person_link in_file1.val base1 iper1 "base1") 61 | MsgBirthDate -> 62 Printf.printf "birth date" 63 | MsgBirthPlace -> 64 Printf.printf "birth place" 65 | MsgChildMissing iper1 -> 66 Printf.printf "child missing: %s" 67 (person_link in_file1.val base1 iper1 "base1") 68 | MsgChildren iper1 -> 69 Printf.printf "more than one child match: %s" 70 (person_link in_file1.val base1 iper1 "base1") 71 | MsgDeathDate -> 72 Printf.printf "death (status or date)" 73 | MsgDeathPlace -> 74 Printf.printf "death place" 75 | MsgDivorce -> 76 Printf.printf "divorce" 77 | MsgFirstName -> 78 Printf.printf "first name" 79 | MsgOccupation -> 80 Printf.printf "occupation" 81 | MsgParentsMissing -> 82 Printf.printf "parents missing" 83 | MsgMarriageDate -> 84 Printf.printf "marriage date" 85 | MsgMarriagePlace -> 86 Printf.printf "marriage place" 87 | MsgSex -> 88 Printf.printf "sex" 89 | MsgSpouseMissing iper1 -> 90 Printf.printf "spouse missing: %s" 91 (person_link in_file1.val base1 iper1 "base1") 92 | MsgSpouses iper1 -> 93 Printf.printf "more than one spouse match: %s" 94 (person_link in_file1.val base1 iper1 "base1") 95 | MsgSurname -> 96 Printf.printf "surname" ]; 97 Printf.printf "%s" cr.val 98 } 99; 100 101value print_f_messages base1 base2 ifam1 ifam2 res = 102 let c1 = coi base1 ifam1 in 103 let c2 = coi base2 ifam2 in 104 do { 105 Printf.printf "%s x %s%s/ %s x %s%s" 106 (person_link in_file1.val base1 c1.father "base1") 107 (person_link in_file1.val base1 c1.mother "base1") 108 cr.val 109 (person_link in_file2.val base2 c2.father "base2") 110 (person_link in_file2.val base2 c2.mother "base2") 111 cr.val; 112 List.iter (print_message base1 base2) res 113 } 114; 115 116value print_p_messages base1 base2 iper1 iper2 res = 117 do { 118 Printf.printf "%s / %s%s" 119 (person_link in_file1.val base1 iper1 "base1") 120 (person_link in_file2.val base2 iper2 "base2") 121 cr.val; 122 List.iter (print_message base1 base2) res 123 } 124; 125 126value compatible_names src_name dest_name_list = 127 let src_name = Name.lower src_name in 128 let dest_name_list = List.map Name.lower dest_name_list in 129 List.mem src_name dest_name_list 130; 131 132value compatible_str_field istr1 istr2 = 133 (Adef.int_of_istr istr1 = 0) || (Adef.int_of_istr istr2 != 0) 134; 135 136value dmy_to_sdn_range_l dmy = 137 let sdn_of_dmy dmy = 138 let sdn = Calendar.sdn_of_gregorian dmy in 139 let sdn = 140 if dmy.month = 0 || dmy.day = 0 then sdn + 1 141 else sdn 142 in 143 let sdn2 = 144 if dmy.delta != 0 then sdn + dmy.delta 145 else 146 let dmy2 = 147 { year = if dmy.month = 0 || 148 (dmy.month = 12 && dmy.day = 0) then (dmy.year +1) 149 else dmy.year; 150 month = if dmy.month = 0 then 1 151 else if dmy.day = 0 then 152 if dmy.month = 12 then 1 153 else dmy.month + 1 154 else dmy.month; 155 day = if dmy.day = 0 then 1 else dmy.day; 156 prec = if dmy.month = 0 || dmy.day = 0 then Before else Sure; 157 delta = dmy.delta } 158 in 159 let sdn2 = Calendar.sdn_of_gregorian dmy2 in 160 if dmy2.prec = Before then sdn2 - 1 else sdn2 161 in 162 (sdn, sdn2) 163 in 164 match dmy.prec with 165 [ Sure -> 166 let (sdn1, sdn2) = sdn_of_dmy dmy in 167 [ (Some sdn1, Some sdn2) ] 168 | Maybe -> 169 let (sdn1, sdn2) = sdn_of_dmy dmy in 170 [ (Some sdn1, Some sdn2) ; (None, None) ] 171 | About -> 172 let (sdn1, sdn2) = sdn_of_dmy dmy in 173 let delta = (sdn2 - sdn1 + 1) * 5 in 174 [ (Some (sdn1 - delta), Some (sdn2 + delta)) ] 175 | Before -> 176 let (sdn1, sdn2) = sdn_of_dmy dmy in 177 [ (None, Some sdn2) ] 178 | After -> 179 let (sdn1, sdn2) = sdn_of_dmy dmy in 180 [ (Some sdn1, None) ] 181 | OrYear y -> 182 let dmy2 = 183 { year = y + 1; 184 month = 0; 185 day = 0; 186 prec = Sure; 187 delta = 0 } 188 in 189 let (sdn11, sdn12) = sdn_of_dmy dmy in 190 let (sdn21, sdn22) = sdn_of_dmy dmy2 in 191 [ (Some sdn11, Some sdn12) ; (Some sdn21, Some sdn22) ] 192 | YearInt y -> 193 let dmy2 = 194 { year = y + 1; 195 month = 0; 196 day = 0; 197 prec = Sure; 198 delta = 0 } 199 in 200 let (sdn11, sdn12) = sdn_of_dmy dmy in 201 let (sdn21, sdn22) = sdn_of_dmy dmy2 in 202 [ (Some sdn11, Some sdn22) ] ] 203; 204 205value compatible_sdn (sdn11, sdn12) (sdn21, sdn22) = 206 if (sdn21, sdn22) = (None, None) then True 207 else 208 let bool1 = 209 match (sdn11, sdn21) with 210 [ (Some sdn1, Some sdn2) -> sdn1 <= sdn2 211 | (None, _) -> True 212 | (Some _, None) -> False ] 213 in 214 let bool2 = 215 match (sdn12, sdn22) with 216 [ (Some sdn1, Some sdn2) -> sdn1 >= sdn2 217 | (None, _) -> True 218 | (Some _, None) -> False ] 219 in 220 bool1 && bool2 221; 222 223value compatible_sdn_l sdn1_l sdn2 = 224 List.fold_left (fun r sdn1 -> r || (compatible_sdn sdn1 sdn2)) 225 False sdn1_l 226; 227 228value compatible_sdn_ll sdn1_l sdn2_l = 229 List.fold_left (fun r sdn2 -> r && (compatible_sdn_l sdn1_l sdn2)) 230 True sdn2_l 231; 232 233value compatible_dmys dmy1 dmy2 = 234 compatible_sdn_ll (dmy_to_sdn_range_l dmy1) (dmy_to_sdn_range_l dmy2) 235; 236 237value compatible_dates date1 date2 = 238 let compatible_cals cal1 cal2 = 239 match (cal1, cal2) with 240 [ (Dgregorian, Djulian) 241 | (Dgregorian, Dfrench) -> True 242 | _ -> cal1 = cal2 ] 243 in 244 if date1 = date2 then True 245 else 246 match (date1, date2) with 247 [ (Dgreg dmy1 cal1, Dgreg dmy2 cal2) -> 248 compatible_dmys dmy1 dmy2 249 && compatible_cals cal1 cal2 250 | (Dgreg _ _, Dtext _) -> False 251 | (Dtext _, _) -> True ] 252; 253 254value compatible_codates codate1 codate2 = 255 let od1 = Adef.od_of_codate codate1 in 256 let od2 = Adef.od_of_codate codate2 in 257 match (od1, od2) with 258 [ (Some date1, Some date2) -> compatible_dates date1 date2 259 | (Some _, None) -> False 260 | (None, _) -> True ] 261; 262 263value compatible_birth base1 base2 p1 p2 = 264 let get_birth person = 265 if person.birth = Adef.codate_None then person.baptism 266 else person.birth 267 in 268 let birth1 = get_birth p1 in 269 let birth2 = get_birth p2 in 270 let res1 = 271 if compatible_codates birth1 birth2 then [] 272 else [ MsgBirthDate ] 273 in 274 let res2 = 275 if compatible_str_field p1.birth_place p2.birth_place then [] 276 else [ MsgBirthPlace ] 277 in 278 res1 @ res2 279; 280 281value compatible_death base1 base2 p1 p2 = 282 let bool1 = 283 p1.death = p2.death || 284 match (p1.death, p2.death) with 285 [ (Death _ cdate1, Death _ cdate2) -> 286 let date1 = Adef.date_of_cdate cdate1 in 287 let date2 = Adef.date_of_cdate cdate2 in 288 compatible_dates date1 date2 289 | (NotDead, _) 290 | (DeadYoung, Death _ _) 291 | (DeadDontKnowWhen, Death _ _ | DeadYoung | DeadDontKnowWhen) 292 | (DontKnowIfDead, _) -> True 293 | _ -> False ] 294 in 295 let res1 = 296 if bool1 then [] 297 else [ MsgDeathDate ] 298 in 299 let res2 = 300 if compatible_str_field p1.death_place p2.death_place then [] 301 else [ MsgDeathPlace ] 302 in 303 res1 @ res2 304; 305 306value compatible_sexes base1 base2 p1 p2 = 307 if p1.sex = p2.sex then [] 308 else [ MsgSex ] 309; 310 311value compatible_occupations base1 base2 p1 p2 = 312 if compatible_str_field p1.occupation p2.occupation then [] 313 else [ MsgOccupation ] 314; 315 316value compatible_persons_ligth base1 base2 p1 p2 = 317 let fn1 = sou base1 p1.first_name in 318 let fn2 = sou base2 p2.first_name in 319 let afn2 = [fn2 :: List.map (sou base2) p2.first_names_aliases] in 320 let sn1 = sou base1 p1.surname in 321 let sn2 = sou base2 p2.surname in 322 let asn2 = [sn2 :: List.map (sou base2) p2.surnames_aliases] in 323 let res1 = 324 if compatible_names fn1 afn2 then [] 325 else [ MsgFirstName ] 326 in 327 let res2 = 328 if compatible_names sn1 asn2 then [] 329 else [ MsgSurname ] 330 in 331 res1 @ res2 332; 333 334value compatible_persons base1 base2 p1 p2 = 335 compatible_persons_ligth base1 base2 p1 p2 336 @ compatible_sexes base1 base2 p1 p2 337 @ compatible_birth base1 base2 p1 p2 338 @ compatible_death base1 base2 p1 p2 339 @ compatible_occupations base1 base2 p1 p2 340; 341 342value rec find_compatible_persons_ligth base1 base2 iper1 iper2_list = 343 match iper2_list with 344 [ [] -> [] 345 | [ head :: rest ] -> 346 let p1 = poi base1 iper1 in 347 let p2 = poi base2 head in 348 let c_rest = find_compatible_persons_ligth base1 base2 iper1 rest in 349 if compatible_persons_ligth base1 base2 p1 p2 = [] then [ head :: c_rest ] 350 else c_rest ] 351; 352 353value rec find_compatible_persons base1 base2 iper1 iper2_list = 354 match iper2_list with 355 [ [] -> [] 356 | [ head :: rest ] -> 357 let p1 = poi base1 iper1 in 358 let p2 = poi base2 head in 359 let c_rest = find_compatible_persons base1 base2 iper1 rest in 360 if compatible_persons base1 base2 p1 p2 = [] then [ head :: c_rest ] 361 else c_rest ] 362; 363 364value compatible_unions base1 base2 iper1 iper2 ifam1 ifam2 = 365 let get_spouse base iper ifam = 366 let c = coi base ifam in 367 if iper = c.father then poi base c.mother 368 else poi base c.father 369 in 370 let spouse1 = get_spouse base1 iper1 ifam1 in 371 let spouse2 = get_spouse base2 iper2 ifam2 in 372 compatible_persons_ligth base1 base2 spouse1 spouse2 373; 374 375value rec find_compatible_unions base1 base2 iper1 iper2 ifam1 ifam2_list = 376 match ifam2_list with 377 [ [] -> [] 378 | [ head :: rest ] -> 379 let c_rest = find_compatible_unions base1 base2 iper1 iper2 ifam1 rest in 380 if compatible_unions base1 base2 iper1 iper2 ifam1 head = [] then 381 [ head :: c_rest ] 382 else c_rest ] 383; 384 385value compatible_divorces d1 d2 = 386 match (d1, d2) with 387 [ (Divorced codate1, Divorced codate2) -> 388 compatible_codates codate1 codate2 389 | (Divorced _, _) -> False 390 | _ -> True ] 391; 392 393value compatible_marriages base1 base2 ifam1 ifam2 = 394 let f1 = foi base1 ifam1 in 395 let f2 = foi base2 ifam2 in 396 let res1 = 397 if compatible_codates f1.marriage f2.marriage then [] 398 else [ MsgMarriageDate ] 399 in 400 let res2 = 401 if compatible_divorces f1.divorce f2.divorce then [] 402 else [ MsgDivorce ] 403 in 404 let res3 = 405 if compatible_str_field f1.marriage_place f2.marriage_place then [] 406 else [ MsgMarriagePlace ] 407 in 408 let res = res1 @ res2 @ res3 in 409 if res = [] then () 410 else print_f_messages base1 base2 ifam1 ifam2 res 411; 412 413value pdiff base1 base2 iper1 iper2 = 414 let p1 = poi base1 iper1 in 415 let p2 = poi base2 iper2 in 416 let res = compatible_persons base1 base2 p1 p2 in 417 if res = [] then () 418 else print_p_messages base1 base2 iper1 iper2 res 419; 420 421value compatible_parents base1 base2 iper1 iper2 = 422 let a1 = (aoi base1 iper1).parents in 423 let a2 = (aoi base2 iper2).parents in 424 match (a1, a2) with 425 [ (Some ifam1, Some ifam2) -> 426 let c1 = coi base1 ifam1 in 427 let c2 = coi base2 ifam2 in 428 let _ = pdiff base1 base2 c1.father c2.father in 429 let _ = pdiff base1 base2 c1.mother c2.mother in 430 compatible_marriages base1 base2 ifam1 ifam2 431 | (None, _) -> () 432 | (Some _, None) -> 433 print_p_messages base1 base2 iper1 iper2 [ MsgParentsMissing ] ] 434; 435 436value rec ddiff base1 base2 iper1 iper2 d_tab = 437 let d_check = d_tab.(Adef.int_of_iper iper1) in 438 if List.mem iper2 d_check then () 439 else 440 let _ = d_tab.(Adef.int_of_iper iper1) := [iper2 :: d_check ] in 441 let spouse c iper = 442 if iper = c.father then c.mother 443 else c.father 444 in 445 let rec udiff base1 base2 iper1 iper2 r ifam1 ifam2 = 446 let fd b1 b2 ip2_list ip1 = 447 match find_compatible_persons_ligth b1 b2 ip1 ip2_list with 448 [ [ip2] -> ddiff base1 base2 ip1 ip2 d_tab 449 | [] -> 450 print_p_messages base1 base2 iper1 iper2 [ MsgChildMissing ip1 ] 451 | rest_list -> 452 match find_compatible_persons b1 b2 ip1 rest_list with 453 [ [best_ip2] -> ddiff base1 base2 ip1 best_ip2 d_tab 454 | [] -> 455 print_p_messages base1 base2 iper1 iper2 [ MsgBadChild ip1 ] 456 | _ -> 457 print_p_messages base1 base2 iper1 iper2 [ MsgChildren ip1 ] ] ] 458 in 459 let c1 = coi base1 ifam1 in 460 let c2 = coi base2 ifam2 in 461 let p1 = spouse c1 iper1 in 462 let p2 = spouse c2 iper2 in 463 let d1 = Array.to_list (doi base1 ifam1).children in 464 let d2 = Array.to_list (doi base2 ifam2).children in 465 do { 466 pdiff base1 base2 p1 p2; 467 List.iter (fd base1 base2 d2) d1 468 } 469 in 470 let fu b1 b2 ifam2_list ifam1 = 471 match find_compatible_unions b1 b2 iper1 iper2 ifam1 ifam2_list with 472 [ [ifam2] -> 473 do { 474 compatible_marriages b1 b2 ifam1 ifam2; 475 compatible_parents b1 b2 (spouse (coi base1 ifam1) iper1) 476 (spouse (coi base2 ifam2) iper2); 477 udiff b1 b2 iper1 iper2 True ifam1 ifam2 478 } 479 | [] -> 480 print_p_messages base1 base2 iper1 iper2 481 [ MsgSpouseMissing (spouse (coi base1 ifam1) iper1) ] 482 | _ -> 483 print_p_messages base1 base2 iper1 iper2 484 [ MsgSpouses (spouse (coi base1 ifam1) iper1) ] ] 485 in 486 let u1 = Array.to_list (uoi base1 iper1).family in 487 let u2 = Array.to_list (uoi base2 iper2).family in 488 do { 489 pdiff base1 base2 iper1 iper2; 490 List.iter (fu base1 base2 u2) u1 491 } 492; 493 494value rec find_top base1 base2 iper1 iper2 = 495 let p1 = poi base1 iper1 in 496 let p2 = poi base2 iper2 in 497 if compatible_persons_ligth base1 base2 p1 p2 = [] then 498 let a1 = (aoi base1 iper1).parents in 499 let a2 = (aoi base2 iper2).parents in 500 match (a1, a2) with 501 [ (Some ifam1, Some ifam2) -> 502 let c1 = coi base1 ifam1 in 503 let c2 = coi base2 ifam2 in 504 let f_top_list = find_top base1 base2 c1.father c2.father in 505 let m_top_list = find_top base1 base2 c1.mother c2.mother in 506 f_top_list @ m_top_list 507 | _ -> [(iper1, iper2)] ] 508 else do { 509 Printf.printf " Warning: %s doesn't match %s%s" 510 (person_link in_file1.val base1 iper1 "base1") 511 (person_link in_file2.val base2 iper2 "base2") 512 cr.val; 513 [] 514 } 515; 516 517value addiff base1 base2 iper1 iper2 d_tab = 518 let topdiff (iper1, iper2) = 519 do { 520 Printf.printf "==> %s / %s%s" 521 (person_link in_file1.val base1 iper1 "base1") 522 (person_link in_file2.val base2 iper2 "base2") 523 cr.val; 524 ddiff base1 base2 iper1 iper2 d_tab 525 } 526 in 527 do { 528 Printf.printf "Building top list...%s" cr.val; 529 let top_list = find_top base1 base2 iper1 iper2 in 530 Printf.printf "Top list built.%s" cr.val; 531 List.iter topdiff top_list 532 } 533; 534 535(* Main *) 536 537value gwdiff base1 base2 iper1 iper2 d_mode ad_mode = 538 let desc_tab = Array.make base1.data.persons.len [] in 539 match (d_mode, ad_mode) with 540 [ (True, _) 541 | (False, False) -> ddiff base1 base2 iper1 iper2 desc_tab 542 | (False, True) -> addiff base1 base2 iper1 iper2 desc_tab ] 543; 544 545value p1_fn = ref ""; 546value p1_occ = ref 0; 547value p1_sn = ref ""; 548value p2_fn = ref ""; 549value p2_occ = ref 0; 550value p2_sn = ref ""; 551 552type arg_state = 553 [ ASnone 554 | ASwaitP1occ 555 | ASwaitP1sn 556 | ASwaitP2occ 557 | ASwaitP2sn ] 558; 559value arg_state = ref ASnone; 560value mem = ref False; 561value d_mode = ref False; 562value ad_mode = ref False; 563 564value speclist = 565 [("-1", Arg.String (fun s -> do { p1_fn.val := s; arg_state.val := ASwaitP1occ }), 566 "<fn> <occ> <sn> : (mandatory) defines starting person in base1"); 567 ("-2", Arg.String (fun s -> do { p2_fn.val := s; arg_state.val := ASwaitP2occ }), 568 "<fn> <occ> <sn> : (mandatory) defines starting person in base2"); 569 ("-ad", Arg.Set ad_mode, 570 ": checks descendants of all ascendants "); 571 ("-d", Arg.Set d_mode, 572 ": checks descendants (default)"); 573 ("-html", Arg.String (fun s -> do { html.val := True; root.val := s }), 574 "<root>: HTML format used for report"); 575 ("-mem", Arg.Set mem, ": save memory space, but slower") ] 576; 577 578value anonfun s = 579 match arg_state.val with 580 [ ASnone -> 581 if in_file1.val = "" then in_file1.val := s 582 else if in_file2.val = "" then in_file2.val := s 583 else raise (Arg.Bad "Too much arguments") 584 | ASwaitP1occ -> 585 try 586 do { 587 p1_occ.val := int_of_string s; 588 arg_state.val := ASwaitP1sn 589 } 590 with 591 [ Failure _ -> raise (Arg.Bad "Numeric value for occ (-1)!") ] 592 | ASwaitP1sn -> do { p1_sn.val := s; arg_state.val := ASnone } 593 | ASwaitP2occ -> 594 try 595 do { 596 p2_occ.val := int_of_string s; 597 arg_state.val := ASwaitP2sn 598 } 599 with 600 [ Failure _ -> raise (Arg.Bad "Numeric value for occ (-2)!") ] 601 | ASwaitP2sn -> do { p2_sn.val := s; arg_state.val := ASnone }] 602; 603 604value errmsg = 605 "Usage: " ^ Sys.argv.(0) ^ " \ 606[options] base1 base2 607Options are: " 608; 609 610value check_args () = 611 do { 612 Argl.parse speclist anonfun errmsg; 613 if in_file1.val = "" then 614 do { 615 Printf.printf "Missing reference data base\n"; 616 Printf.printf "Use option -help for usage\n"; 617 flush stdout; 618 exit 2 619 } 620 else (); 621 if in_file2.val = "" then 622 do { 623 Printf.printf "Missing destination data base\n"; 624 Printf.printf "Use option -help for usage\n"; 625 flush stdout; 626 exit 2 627 } 628 else (); 629 if p1_fn.val = "" then 630 do { 631 Printf.printf "-1 parameter is mandatory\n"; 632 Printf.printf "Use option -help for usage\n"; 633 flush stdout; 634 exit 2 635 } 636 else (); 637 if p1_sn.val = "" then 638 do { 639 Printf.printf "Incomplete -1 parameter\n"; 640 Printf.printf "Use option -help for usage\n"; 641 flush stdout; 642 exit 2 643 } 644 else (); 645 if p2_fn.val = "" then 646 do { 647 Printf.printf "-2 parameter is mandatory\n"; 648 Printf.printf "Use option -help for usage\n"; 649 flush stdout; 650 exit 2 651 } 652 else (); 653 if p2_sn.val = "" then 654 do { 655 Printf.printf "Incomplete -2 parameter\n"; 656 Printf.printf "Use option -help for usage\n"; 657 flush stdout; 658 exit 2 659 } 660 else () 661 } 662; 663 664value main () = 665 let _ = check_args () in 666 let _ = 667 if not html.val then cr.val := "\n" 668 else cr.val := "<BR>\n" 669 in 670 (* Reference base *) 671 let base1 = Iobase.input in_file1.val in 672 let _ = base1.data.ascends.array () in 673 let _ = base1.data.strings.array () in 674 let _ = 675 if not mem.val then 676 let _ = base1.data.persons.array () in 677 let _ = base1.data.families.array () in 678 let _ = base1.data.couples.array () in 679 let _ = base1.data.unions.array () in 680 let _ = base1.data.descends.array () in 681 () 682 else () 683 in 684 (* Destination base *) 685 let base2 = 686 if in_file1.val != in_file2.val then 687 let base2 = Iobase.input in_file2.val in 688 let _ = base2.data.ascends.array () in 689 let _ = base2.data.strings.array () in 690 let _ = 691 if not mem.val then 692 let _ = base2.data.persons.array () in 693 let _ = base2.data.families.array () in 694 let _ = base2.data.couples.array () in 695 let _ = base2.data.unions.array () in 696 let _ = base2.data.descends.array () in 697 () 698 else () 699 in 700 base2 701 else 702 (* Reference = Destination *) 703 base1 704 in 705 let iper1 = person_ht_find_unique base1 p1_fn.val p1_sn.val p1_occ.val in 706 let iper2 = person_ht_find_unique base2 p2_fn.val p2_sn.val p2_occ.val in 707 do { 708 if html.val then 709 Printf.printf "<BODY>\n" 710 else (); 711 gwdiff base1 base2 iper1 iper2 d_mode.val ad_mode.val; 712 if html.val then 713 Printf.printf "</BODY>\n" 714 else () 715 } 716; 717 718Printexc.catch main (); 719