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

open Config
open Def
open Gwdb
open Util

let rec merge_lists l1 = function
  | x2 :: l2 ->
      if List.mem x2 l1 then merge_lists l1 l2 else merge_lists (l1 @ [ x2 ]) l2
  | [] -> l1

let merge_strings base is1 sep is2 =
  let n1 = sou base is1 in
  let n2 = sou base is2 in
  if n1 = n2 then n1
  else if n1 = "" then n2
  else if n2 = "" then n1
  else n1 ^ sep ^ n2

let sorp base ip =
  let p = poi base ip in
  ( sou base (get_first_name p),
    sou base (get_surname p),
    get_occ p,
    Update.Link,
    "" )

let merge_event_witnesses wit1 wit2 =
  let list =
    Array.fold_right
      (fun wit list -> if List.mem wit list then list else wit :: list)
      wit1 (Array.to_list wit2)
  in
  Array.of_list list

let merge_events l1 l2 p =
  let list_mem e l =
    let found_birth = ref false in
    let found_baptism = ref false in
    let found_death = ref false in
    let found_burial = ref false in
    match e.epers_name with
    | Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial | Epers_Cremation
      ->
        List.fold_right
          (fun e1 (mem, l1) ->
            match e1.epers_name with
            | Epers_Birth ->
                if !found_birth then (mem, e1 :: l1)
                else if e.epers_name = e1.epers_name then
                  let witnesses =
                    merge_event_witnesses e1.epers_witnesses e.epers_witnesses
                  in
                  let e1 =
                    {
                      e1 with
                      epers_date = p.birth;
                      epers_place = p.birth_place;
                      epers_note = p.birth_note;
                      epers_src = p.birth_src;
                      epers_witnesses = witnesses;
                    }
                  in
                  let _ = found_birth := true in
                  (true, e1 :: l1)
                else (mem, e1 :: l1)
            | Epers_Baptism ->
                if !found_baptism then (mem, e1 :: l1)
                else if e.epers_name = e1.epers_name then
                  let witnesses =
                    merge_event_witnesses e1.epers_witnesses e.epers_witnesses
                  in
                  let e1 =
                    {
                      e1 with
                      epers_date = p.baptism;
                      epers_place = p.baptism_place;
                      epers_note = p.baptism_note;
                      epers_src = p.baptism_src;
                      epers_witnesses = witnesses;
                    }
                  in
                  let _ = found_baptism := true in
                  (true, e1 :: l1)
                else (mem, e1 :: l1)
            | Epers_Death ->
                if !found_death then (mem, e1 :: l1)
                else if e.epers_name = e1.epers_name then
                  let is_dead, date =
                    match p.death with
                    | NotDead | DontKnowIfDead -> (false, Date.cdate_None)
                    | Death (_, cd) -> (true, cd)
                    | DeadYoung | DeadDontKnowWhen | OfCourseDead ->
                        (true, Date.cdate_None)
                  in
                  let witnesses =
                    merge_event_witnesses e1.epers_witnesses e.epers_witnesses
                  in
                  let e1 =
                    {
                      e1 with
                      epers_date = date;
                      epers_place = p.death_place;
                      epers_note = p.death_note;
                      epers_src = p.death_src;
                      epers_witnesses = witnesses;
                    }
                  in
                  let _ = found_death := true in
                  if is_dead then (true, e1 :: l1) else (true, l1)
                else (mem, e1 :: l1)
            | Epers_Burial ->
                if !found_burial then (mem, e1 :: l1)
                else if e.epers_name = e1.epers_name then
                  match p.burial with
                  | UnknownBurial ->
                      let _ = found_burial := true in
                      (true, l1)
                  | Buried cd ->
                      let witnesses =
                        merge_event_witnesses e1.epers_witnesses
                          e.epers_witnesses
                      in
                      let e1 =
                        {
                          e1 with
                          epers_date = cd;
                          epers_place = p.burial_place;
                          epers_note = p.burial_note;
                          epers_src = p.burial_src;
                          epers_witnesses = witnesses;
                        }
                      in
                      let _ = found_burial := true in
                      (true, e1 :: l1)
                  | _ ->
                      let _ = found_burial := true in
                      (mem, e1 :: l1)
                else (mem, e1 :: l1)
            | Epers_Cremation ->
                if !found_burial then (mem, e1 :: l1)
                else if e.epers_name = e1.epers_name then
                  match p.burial with
                  | UnknownBurial ->
                      let _ = found_burial := true in
                      (true, l1)
                  | Cremated cd ->
                      let witnesses =
                        merge_event_witnesses e1.epers_witnesses
                          e.epers_witnesses
                      in
                      let e1 =
                        {
                          e1 with
                          epers_date = cd;
                          epers_place = p.burial_place;
                          epers_note = p.burial_note;
                          epers_src = p.burial_src;
                          epers_witnesses = witnesses;
                        }
                      in
                      let _ = found_burial := true in
                      (true, e1 :: l1)
                  | _ ->
                      let _ = found_burial := true in
                      (mem, e1 :: l1)
                else (mem, e1 :: l1)
            | _ -> (mem, e1 :: l1))
          l (false, [])
    | _ -> (false, l)
  in
  let rec merge_events_aux l1 l2 =
    match l2 with
    | [] -> l1
    | e2 :: l2 ->
        let mem, l1 = list_mem e2 l1 in
        if mem then merge_events_aux l1 l2
        else merge_events_aux (l1 @ [ e2 ]) l2
  in
  merge_events_aux l1 l2

let reconstitute conf base p1 p2 =
  let field name proj null =
    let x1 = proj p1 in
    let x2 = proj p2 in
    match p_getenv conf.env name with
    | Some "1" -> x1
    | Some "2" -> x2
    | _ -> if null x1 then x2 else x1
  in
  let list conv proj =
    let l1 = List.map conv (proj p1) in
    let l2 = List.map conv (proj p2) in
    merge_lists l1 l2
  in
  let merge_primary_events conv proj p =
    let l1 = List.map conv (proj p1) in
    let l2 = List.map conv (proj p2) in
    merge_events l1 l2 p
  in
  let p =
    {
      first_name =
        field "first_name"
          (fun p -> p_first_name base p)
          (fun x -> x = "" || x = "?");
      surname =
        field "surname" (fun p -> p_surname base p) (fun x -> x = "" || x = "?");
      occ = field "number" get_occ (( = ) 0);
      image =
        field "image"
          (fun p ->
            match Image.get_portrait conf base p with
            | Some src -> Image.src_to_string src
            | None -> "")
          (( = ) "");
      public_name =
        field "public_name" (fun p -> sou base (get_public_name p)) (( = ) "");
      qualifiers = list (sou base) get_qualifiers;
      aliases = list (sou base) get_aliases;
      first_names_aliases = list (sou base) get_first_names_aliases;
      surnames_aliases = list (sou base) get_surnames_aliases;
      titles = list (Futil.map_title_strings (sou base)) get_titles;
      rparents =
        list (Futil.map_relation_ps (sorp base) (sou base)) get_rparents;
      related = [];
      occupation =
        field "occupation" (fun p -> sou base (get_occupation p)) (( = ) "");
      sex = field "sex" get_sex (( = ) Neuter);
      access = field "access" get_access (( = ) IfTitles);
      birth = field "birth" get_birth (( = ) Date.cdate_None);
      birth_place =
        field "birth_place" (fun p -> sou base (get_birth_place p)) (( = ) "");
      birth_note =
        merge_strings base (get_birth_note p1) "<br>\n" (get_birth_note p2);
      birth_src = merge_strings base (get_birth_src p1) ", " (get_birth_src p2);
      baptism = field "baptism" get_baptism (( = ) Date.cdate_None);
      baptism_place =
        field "baptism_place"
          (fun p -> sou base (get_baptism_place p))
          (( = ) "");
      baptism_note =
        merge_strings base (get_baptism_note p1) "<br>\n" (get_baptism_note p2);
      baptism_src =
        merge_strings base (get_baptism_src p1) ", " (get_baptism_src p2);
      death =
        field "death" get_death (fun x ->
            match x with DontKnowIfDead | OfCourseDead -> true | _ -> false);
      death_place =
        field "death_place" (fun p -> sou base (get_death_place p)) (( = ) "");
      death_note =
        merge_strings base (get_death_note p1) "<br>\n" (get_death_note p2);
      death_src = merge_strings base (get_death_src p1) ", " (get_death_src p2);
      burial = field "burial" get_burial (( = ) UnknownBurial);
      burial_place =
        field "burial_place" (fun p -> sou base (get_burial_place p)) (( = ) "");
      burial_note =
        merge_strings base (get_burial_note p1) "<br>\n" (get_burial_note p2);
      burial_src =
        merge_strings base (get_burial_src p1) ", " (get_burial_src p2);
      pevents = list (Futil.map_pers_event (sorp base) (sou base)) get_pevents;
      notes = merge_strings base (get_notes p1) "<br>\n" (get_notes p2);
      psources = merge_strings base (get_psources p1) ", " (get_psources p2);
      key_index = get_iper p1;
    }
  in
  (* On fait la fusion des évènements à partir *)
  (* de la fusion des évènements principaux.   *)
  let pevents =
    merge_primary_events
      (Futil.map_pers_event (sorp base) (sou base))
      get_pevents p
  in
  { p with pevents }

let redirect_relations_of_added_related base p ip2 rel_chil =
  let p_related, mod_p =
    List.fold_right
      (fun ipc (p_related, mod_p) ->
        let pc = poi base ipc in
        let pc_rparents, _, p_related, mod_p =
          List.fold_right
            (fun r (pc_rparents, mod_pc, p_related, mod_p) ->
              let r, mod_pc, p_related, mod_p =
                match r.r_fath with
                | Some ip when ip = ip2 ->
                    let p_related, mod_p =
                      if List.mem ipc p_related then (p_related, mod_p)
                      else (ipc :: p_related, true)
                    in
                    let r = { r with r_fath = Some p.key_index } in
                    (r, true, p_related, mod_p)
                | _ -> (r, mod_pc, p_related, mod_p)
              in
              let r, mod_pc, p_related, mod_p =
                match r.r_moth with
                | Some ip when ip = ip2 ->
                    let p_related, mod_p =
                      if List.mem ipc p_related then (p_related, mod_p)
                      else (ipc :: p_related, true)
                    in
                    let r = { r with r_moth = Some p.key_index } in
                    (r, true, p_related, mod_p)
                | _ -> (r, mod_pc, p_related, mod_p)
              in
              (r :: pc_rparents, mod_pc, p_related, mod_p))
            (get_rparents pc)
            ([], false, p_related, mod_p)
        in
        let pc_pevents, mod_pc, p_related, mod_p =
          List.fold_right
            (fun e (pc_pevents, mod_pc, p_related, _) ->
              let e, mod_pc, p_related, mod_p =
                let witnesses, mod_p, p_related =
                  List.fold_right
                    (fun (ip, k) (witnesses, mod_p, p_related) ->
                      if ip = ip2 then
                        let p_related, mod_p =
                          if List.mem ipc p_related then (p_related, mod_p)
                          else (ipc :: p_related, true)
                        in
                        ((p.key_index, k) :: witnesses, mod_p, p_related)
                      else ((ip, k) :: witnesses, mod_p, p_related))
                    (Array.to_list e.epers_witnesses)
                    ([], mod_pc, p_related)
                in
                let e = { e with epers_witnesses = Array.of_list witnesses } in
                (e, true, p_related, mod_p)
              in
              (e :: pc_pevents, mod_pc, p_related, mod_p))
            (get_pevents pc)
            ([], false, p_related, mod_p)
        in
        (* TODO mod_pc = True tout le temps *)
        (if mod_pc then
         let pc = gen_person_of_person pc in
         let pc = { pc with rparents = pc_rparents; pevents = pc_pevents } in
         patch_person base ipc pc);
        let p_related, mod_p =
          let rec loop (p_related, mod_p) i =
            if i = Array.length (get_family pc) then (p_related, mod_p)
            else
              let ifam = (get_family pc).(i) in
              let fam = gen_family_of_family (foi base ifam) in
              let p_related, mod_p =
                if Array.mem ip2 fam.witnesses then (
                  let p_related, mod_p =
                    let rec loop (p_related, mod_p) j =
                      if j = Array.length fam.witnesses then (p_related, mod_p)
                      else
                        let p_related, mod_p =
                          if fam.witnesses.(j) = ip2 then (
                            fam.witnesses.(j) <- p.key_index;
                            if List.mem ipc p_related then (p_related, mod_p)
                            else (ipc :: p_related, true))
                          else (p_related, mod_p)
                        in
                        loop (p_related, mod_p) (j + 1)
                    in
                    loop (p_related, mod_p) 0
                  in
                  patch_family base ifam fam;
                  (p_related, mod_p))
                else (p_related, mod_p)
              in
              let pc_fevents, mod_pc, p_related, mod_p =
                List.fold_right
                  (fun e (pc_fevents, _, p_related, mod_p) ->
                    let e, mod_pc, p_related, mod_p =
                      let p_related, mod_p =
                        let rec loop (p_related, mod_p) j =
                          if j = Array.length e.efam_witnesses then
                            (p_related, mod_p)
                          else
                            let p_related, mod_p =
                              if fst e.efam_witnesses.(j) = ip2 then (
                                let _, wk = e.efam_witnesses.(j) in
                                e.efam_witnesses.(j) <- (p.key_index, wk);
                                if List.mem ipc p_related then (p_related, mod_p)
                                else (ipc :: p_related, true))
                              else (p_related, mod_p)
                            in
                            loop (p_related, mod_p) (j + 1)
                        in
                        loop (p_related, mod_p) 0
                      in
                      (e, true, p_related, mod_p)
                    in
                    (e :: pc_fevents, mod_pc, p_related, mod_p))
                  fam.fevents
                  ([], false, p_related, mod_p)
              in
              let () =
                (* TODO mod_pc = True tout le temps *)
                if mod_pc then
                  let fam = { fam with fevents = pc_fevents } in
                  patch_family base ifam fam
              in
              loop (p_related, mod_p) (i + 1)
          in
          loop (p_related, mod_p) 0
        in
        (p_related, mod_p))
      rel_chil (p.related, false)
  in
  if mod_p then { p with related = p_related } else p

let redirect_added_families base p ip2 p2_family =
  for i = 0 to Array.length p2_family - 1 do
    let ifam = p2_family.(i) in
    let fam = foi base ifam in
    let cpl =
      if ip2 = get_father fam then (
        Array.iter
          (fun ip ->
            let w = poi base ip in
            if not (List.mem p.key_index (get_related w)) then
              let w = gen_person_of_person w in
              let w = { w with related = p.key_index :: w.related } in
              patch_person base ip w)
          (get_witnesses fam);
        List.iter
          (fun evt ->
            Array.iter
              (fun (ip, _) ->
                let w = poi base ip in
                if not (List.mem p.key_index (get_related w)) then
                  let w = gen_person_of_person w in
                  let w = { w with related = p.key_index :: w.related } in
                  patch_person base ip w)
              evt.efam_witnesses)
          (get_fevents fam);
        Gutil.couple false p.key_index (get_mother fam))
      else if ip2 = get_mother fam then
        Gutil.couple false (get_father fam) p.key_index
      else assert false
    in
    patch_couple base ifam cpl
  done

let effective_mod_merge o_conf base o_p1 o_p2 sp print_mod_merge_ok =
  let conf = Update.update_conf o_conf in
  let p_family = get_family (poi base sp.key_index) in
  let p2_family = get_family (poi base o_p2.key_index) in
  let warning _ = () in
  MergeInd.reparent_ind base warning sp.key_index o_p2.key_index;
  let p =
    UpdateIndOk.effective_mod ~skip_conflict:o_p2.key_index conf base sp
  in
  let p =
    redirect_relations_of_added_related base p o_p2.key_index o_p2.related
  in
  redirect_added_families base p o_p2.key_index p2_family;
  UpdateIndOk.effective_del_no_commit base o_p2;
  patch_person base p.key_index p;
  let u = { family = Array.append p_family p2_family } in
  if p2_family <> [||] then patch_union base p.key_index u;
  Consang.check_noloop_for_person_list base
    (Update.def_error conf base)
    [ p.key_index ];
  let wl =
    let a = poi base p.key_index in
    let a = { parents = get_parents a; consang = get_consang a } in
    UpdateIndOk.all_checks_person base p a u
  in
  Util.commit_patches conf base;
  History.record conf base
    (U_Merge_person (o_p1, o_p2, Util.string_gen_person base p))
    "fp";
  Notes.update_notes_links_db base (Def.NLDB.PgInd o_p2.key_index) "";
  Update.delete_topological_sort conf base;
  let db = Gwdb.read_nldb base in
  let ofn1 = o_p1.first_name in
  let osn1 = o_p1.surname in
  let oocc1 = o_p1.occ in
  let pgl1 =
    Perso.links_to_ind conf base db (Name.lower ofn1, Name.lower osn1, oocc1)
  in
  let ofn2 = o_p2.first_name in
  let osn2 = o_p2.surname in
  let oocc2 = o_p2.occ in
  let pgl2 =
    Perso.links_to_ind conf base db (Name.lower ofn2, Name.lower osn2, oocc2)
  in
  print_mod_merge_ok conf base wl p pgl1 ofn1 osn1 oocc1 pgl2 ofn2 osn2 oocc2
