(* Copyright (c) 1998-2007 INRIA *)

open Def
open Gwdb

let compatible_cdates cd1 cd2 =
  cd1 = cd2 || cd2 = Date.cdate_None || cd1 = Date.cdate_None

let compatible_death_reasons dr1 dr2 = dr1 = dr2 || dr2 = Unspecified

let compatible_deaths d1 d2 =
  if d1 = d2 then true
  else
    match (d1, d2) with
    | Death (dr1, cd1), Death (dr2, cd2) ->
        compatible_death_reasons dr1 dr2 && compatible_cdates cd1 cd2
    | Death (_, _), NotDead -> false
    | Death (_, _), _ -> true
    | _, DontKnowIfDead -> true
    | DontKnowIfDead, _ -> true
    | _ -> false

let compatible_burials b1 b2 =
  if b1 = b2 then true
  else
    match (b1, b2) with
    | _, UnknownBurial -> true
    | UnknownBurial, _ -> true
    | Buried cd1, Buried cd2 -> compatible_cdates cd1 cd2
    | Cremated cd1, Cremated cd2 -> compatible_cdates cd1 cd2
    | _ -> false

let compatible_strings s1 s2 =
  eq_istr s1 s2 || is_empty_string s2 || is_empty_string s1

let compatible_divorces d1 d2 = d1 = d2
let compatible_separations d1 d2 = d1 = d2
let compatible_relation_kinds rk1 rk2 = rk1 = rk2

let compatible_titles t1 t2 =
  Futil.eq_lists (Futil.eq_titles eq_istr) t1 t2 || t2 = []

let compatible_pevents pevt1 pevt2 = pevt1 = [] && pevt2 = []
let compatible_fevents fevt1 fevt2 = fevt1 = [] && fevt2 = []

let compatible_strings_lists sl1 sl2 =
  sl2 = [] || Futil.eq_lists eq_istr sl1 sl2

let compatible_notes base s1 s2 =
  compatible_strings s1 s2 || sou base s1 = sou base s2

let compatible_ind base p1 p2 =
  eq_istr (get_first_name p1) (get_first_name p2)
  && eq_istr (get_surname p1) (get_surname p2)
  && compatible_strings (get_image p1) (get_image p2)
  && compatible_strings (get_public_name p1) (get_public_name p2)
  && compatible_strings_lists (get_qualifiers p1) (get_qualifiers p2)
  && compatible_strings_lists (get_aliases p1) (get_aliases p2)
  && compatible_strings_lists
       (get_first_names_aliases p1)
       (get_first_names_aliases p2)
  && compatible_strings_lists (get_surnames_aliases p1)
       (get_surnames_aliases p2)
  && compatible_titles (get_titles p1) (get_titles p2)
  && compatible_pevents (get_pevents p1) (get_pevents p2)
  && get_rparents p2 = []
  && get_related p2 = []
  && compatible_strings (get_occupation p1) (get_occupation p2)
  && compatible_cdates (get_birth p1) (get_birth p2)
  && compatible_strings (get_birth_place p1) (get_birth_place p2)
  && compatible_cdates (get_baptism p1) (get_baptism p2)
  && compatible_strings (get_baptism_place p1) (get_baptism_place p2)
  && compatible_deaths (get_death p1) (get_death p2)
  && compatible_strings (get_death_place p1) (get_death_place p2)
  && compatible_burials (get_burial p1) (get_burial p2)
  && compatible_strings (get_burial_place p1) (get_burial_place p2)
  && compatible_notes base (get_notes p1) (get_notes p2)

let compatible_fam fam1 fam2 =
  compatible_cdates (get_marriage fam1) (get_marriage fam2)
  && compatible_strings (get_marriage_place fam1) (get_marriage_place fam2)
  && Array.length (get_witnesses fam2) = 0
  && compatible_fevents (get_fevents fam1) (get_fevents fam2)
  && compatible_relation_kinds (get_relation fam1) (get_relation fam2)
  (* TODO can we skip get_divorce and get_separation! treated as fevents *)
  && compatible_divorces (get_divorce fam1) (get_divorce fam2)
  && compatible_separations (get_separation fam1) (get_separation fam2)
  && compatible_strings (get_fsources fam1) (get_fsources fam2)

let reparent_ind base (warning : CheckItem.base_warning -> unit) ip1 ip2 =
  let a1 = poi base ip1 in
  let a2 = poi base ip2 in
  match (get_parents a1, get_parents a2) with
  | None, Some ifam ->
      let des = gen_descend_of_family (foi base ifam) in
      let rec replace i =
        if des.children.(i) = ip2 then des.children.(i) <- ip1
        else replace (i + 1)
      in
      replace 0;
      let a1 = { parents = Some ifam; consang = Adef.fix (-1) } in
      patch_ascend base ip1 a1;
      patch_descend base ifam des
  | Some ifam, None -> (
      let fam = foi base ifam in
      let children = get_children fam in
      match CheckItem.sort_children base children with
      | Some (b, a) ->
          let des = gen_descend_of_family fam in
          patch_descend base ifam des;
          warning (ChangedOrderOfChildren (ifam, fam, b, a))
      | None -> ())
  | _ -> ()

let effective_merge_ind conf base (warning : CheckItem.base_warning -> unit) p1
    p2 =
  let u2 = poi base (get_iper p2) in
  if Array.length (get_family u2) <> 0 then (
    for i = 0 to Array.length (get_family u2) - 1 do
      let ifam = (get_family u2).(i) in
      let cpl = foi base ifam in
      let cpl =
        if get_iper p2 = get_father cpl then
          Gutil.couple false (get_iper p1) (get_mother cpl)
        else if get_iper p2 = get_mother cpl then
          Gutil.couple false (get_father cpl) (get_iper p1)
        else assert false
      in
      patch_couple base ifam cpl
    done;
    let u1 = { family = Array.append (get_family p1) (get_family u2) } in
    patch_union base (get_iper p1) u1;
    let u2 = { family = [||] } in
    patch_union base (get_iper p2) u2);
  let p1 =
    let get_string fn = if is_empty_string (fn p1) then fn p2 else fn p1 in
    {
      (gen_person_of_person p1) with
      sex = (if get_sex p2 <> Neuter then get_sex p2 else get_sex p1);
      birth =
        (if get_birth p1 = Date.cdate_None then get_birth p2 else get_birth p1);
      birth_place = get_string get_birth_place;
      birth_src = get_string get_birth_src;
      baptism =
        (if get_baptism p1 = Date.cdate_None then get_baptism p2
        else get_baptism p1);
      baptism_place = get_string get_baptism_place;
      baptism_src = get_string get_baptism_src;
      death =
        (if get_death p1 = DontKnowIfDead then get_death p2 else get_death p1);
      death_place = get_string get_death_place;
      death_src = get_string get_death_src;
      burial =
        (if get_burial p1 = UnknownBurial then get_burial p2 else get_burial p1);
      burial_place = get_string get_burial_place;
      burial_src = get_string get_burial_src;
      occupation = get_string get_occupation;
      notes = get_string get_notes;
    }
  in
  patch_person base p1.key_index p1;
  reparent_ind base warning p1.key_index (get_iper p2);
  UpdateIndOk.effective_del conf base p2;
  let s =
    let sl =
      [
        p1.notes;
        p1.occupation;
        p1.birth_note;
        p1.birth_src;
        p1.baptism_note;
        p1.baptism_src;
        p1.death_note;
        p1.death_src;
        p1.burial_note;
        p1.burial_src;
        p1.psources;
      ]
    in
    let sl =
      let rec loop l accu =
        match l with
        | [] -> accu
        | evt :: l -> loop l (evt.epers_note :: evt.epers_src :: accu)
      in
      loop p1.pevents sl
    in
    String.concat " " (List.map (sou base) sl)
  in
  Notes.update_notes_links_db base (Def.NLDB.PgInd p1.key_index) s

exception Error_loop of person
exception Same_person
exception Different_sexes of person * person

let is_ancestor base p1 p2 =
  let module IperSet = Util.IperSet in
  let ip1 = get_iper p1 in
  let ip2 = get_iper p2 in
  if ip1 = ip2 then raise Same_person
  else
    let rec loop set = function
      | [] -> false
      | ip :: tl -> (
          if IperSet.mem ip set then loop set tl
          else if ip = ip1 then true
          else
            let set = IperSet.add ip set in
            match get_parents (poi base ip) with
            | Some ifam ->
                let cpl = foi base ifam in
                loop set (get_father cpl :: get_mother cpl :: tl)
            | None -> loop set tl)
    in
    loop IperSet.empty [ ip2 ]

let check_ind base p1 p2 =
  if get_sex p1 <> get_sex p2 && get_sex p1 <> Neuter && get_sex p2 <> Neuter
  then raise @@ Different_sexes (p1, p2)
  else if is_ancestor base p1 p2 then raise (Error_loop p2)
  else if is_ancestor base p2 p1 then raise (Error_loop p1)
  else compatible_ind base p1 p2

let merge_ind conf base warning branches p1 p2 changes_done propose_merge_ind =
  if check_ind base p1 p2 then (
    effective_merge_ind conf base warning p1 p2;
    (true, true))
  else (
    propose_merge_ind conf base branches p1 p2;
    (false, changes_done))

let effective_merge_fam conf base ifam1 fam1 fam2 =
  let des1 = fam1 in
  let des2 = fam2 in
  let fam1 =
    {
      (gen_family_of_family fam1) with
      marriage =
        (if get_marriage fam1 = Date.cdate_None then get_marriage fam2
        else get_marriage fam1);
      marriage_place =
        (if is_empty_string (get_marriage_place fam1) then
         get_marriage_place fam2
        else get_marriage_place fam1);
      marriage_src =
        (if is_empty_string (get_marriage_src fam1) then get_marriage_src fam2
        else get_marriage_src fam1);
      fsources =
        (if is_empty_string (get_fsources fam1) then get_fsources fam2
        else get_fsources fam1);
    }
  in
  let des1 =
    let children = Array.append (get_children des1) (get_children des2) in
    let _ = (CheckItem.sort_children base children : _ option) in
    { children }
  in
  UpdateFamOk.effective_del conf base Gwdb.dummy_iper fam2;
  for i = 0 to Array.length (get_children des2) - 1 do
    let ip = (get_children des2).(i) in
    let a = { parents = Some ifam1; consang = Adef.fix (-1) } in
    patch_ascend base ip a
  done;
  patch_family base ifam1 fam1;
  patch_descend base ifam1 des1

let merge_fam conf base branches ifam1 ifam2 fam1 fam2 ip1 ip2 changes_done
    propose_merge_fam =
  let p1 = poi base ip1 in
  let p2 = poi base ip2 in
  if compatible_fam fam1 fam2 then (
    effective_merge_fam conf base ifam1 fam1 fam2;
    (true, true))
  else (
    propose_merge_fam conf base branches (ifam1, fam1) (ifam2, fam2) p1 p2;
    (false, changes_done))

let rec try_merge conf base warning branches ip1 ip2 changes_done
    propose_merge_ind propose_merge_fam =
  let p1 = poi base ip1 in
  let p2 = poi base ip2 in
  let ok_so_far = true in
  let ok_so_far, changes_done =
    match (get_parents p1, get_parents p2) with
    | Some ifam1, Some ifam2 when ifam1 <> ifam2 ->
        let branches = (ip1, ip2) :: branches in
        let fam1 = foi base ifam1 in
        let fam2 = foi base ifam2 in
        let f1 = get_father fam1 in
        let f2 = get_father fam2 in
        let m1 = get_mother fam1 in
        let m2 = get_mother fam2 in
        let ok_so_far, changes_done =
          if ok_so_far then
            if f1 = f2 then (true, changes_done)
            else
              try_merge conf base ignore branches f1 f2 changes_done
                propose_merge_ind propose_merge_fam
          else (false, changes_done)
        in
        let ok_so_far, changes_done =
          if ok_so_far then
            if m1 = m2 then (true, changes_done)
            else
              try_merge conf base ignore branches m1 m2 changes_done
                propose_merge_ind propose_merge_fam
          else (false, changes_done)
        in
        let ok_so_far, changes_done =
          if ok_so_far then
            merge_fam conf base branches ifam1 ifam2 fam1 fam2 f1 m1
              changes_done propose_merge_fam
          else (false, changes_done)
        in
        (ok_so_far, changes_done)
    | _ -> (ok_so_far, changes_done)
  in
  if ok_so_far then
    merge_ind conf base warning branches p1 p2 changes_done propose_merge_ind
  else (false, changes_done)

let merge conf base p1 p2 propose_merge_ind propose_merge_fam =
  let rev_wl = ref [] in
  let warning w = rev_wl := w :: !rev_wl in
  let ok, changes_done =
    try_merge conf base warning [] (get_iper p1) (get_iper p2) false
      propose_merge_ind propose_merge_fam
  in
  if changes_done then Util.commit_patches conf base;
  (if ok then
   let changed =
     let p1 = Util.string_gen_person base (gen_person_of_person p1) in
     let p2 = Util.string_gen_person base (gen_person_of_person p2) in
     U_Merge_person (p2, p1, p1)
   in
   History.record conf base changed "fp");
  Update.delete_topological_sort conf base;
  (ok, List.rev !rev_wl)

(* Undocumented feature... Kill someone's ancestors *)

let rec kill_ancestors conf base included_self p nb_ind nb_fam =
  (match get_parents p with
  | Some ifam ->
      let cpl = foi base ifam in
      kill_ancestors conf base true (poi base (get_father cpl)) nb_ind nb_fam;
      kill_ancestors conf base true (poi base (get_mother cpl)) nb_ind nb_fam;
      UpdateFamOk.effective_del conf base Gwdb.dummy_iper cpl;
      incr nb_fam
  | None -> ());
  if included_self then (
    UpdateIndOk.effective_del conf base p;
    incr nb_ind)
