(* $Id: mergeFamOk.ml,v 5.19 2007-09-12 09:58:44 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)

open Config
open Def
open Gwdb
open Util

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

let merge_strings base is1 sep is2 =
  if eq_istr is1 is2 then sou base is1 else cat_strings base is1 sep is2

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,
    "" )

(* TODO: O(n^2) *)
let merge_witnesses base wit1 wit2 =
  Array.of_list
  @@ Array.fold_right
       (fun wit list -> if List.mem wit list then list else wit :: list)
       (Array.map (sorp base) wit1)
       (List.map (sorp base) (Array.to_list wit2))

(* TODO: O(n^2) *)
let merge_event_witnesses wit1 wit2 =
  Array.of_list
  @@ Array.fold_right
       (fun wit list -> if List.mem wit list then list else wit :: list)
       wit1 (Array.to_list wit2)

(* ********************************************************************** *)
(*  [Fonc] merge_events : config -> list -> list -> list                  *)

(* ********************************************************************** *)

(** [Description] : Essaye de merger le plus possible d'evenement famille
                    a partir des deux listes d'evenements famille.
    [Args] :
      - l1   : fevents de fam1
      - l2   : fevents de fam2
    [Retour] : la fusion des fevents
    [Rem] : Non exporté en clair hors de ce module.                       *)
let merge_events conf l1 l2 =
  let merge_strings s1 sep s2 =
    if s1 = s2 then s1
    else if s1 = "" then s2
    else if s2 = "" then s1
    else s1 ^ sep ^ s2
  in
  let field x1 x2 null = if null x1 then x2 else x1 in
  let need_selection x1 x2 = x1 <> "" && x2 <> "" && x1 <> x2 in
  let string_event_date e =
    match Date.od_of_cdate e.efam_date with
    | None -> Adef.safe ""
    | Some d -> DateDisplay.string_of_ondate conf d
  in
  let can_merge_event e1 e2 =
    not
      (need_selection
         (string_event_date e1 :> string)
         (string_event_date e2 :> string)
      || need_selection e1.efam_place e2.efam_place
      || need_selection e1.efam_note e2.efam_note
      || need_selection e1.efam_src e2.efam_src)
  in
  let list_mem e l =
    let found_marriage = ref false in
    let found_divorce = ref false in
    match e.efam_name with
    | Efam_Marriage | Efam_NoMarriage | Efam_NoMention | Efam_Engage
    | Efam_Divorce | Efam_Separated ->
        List.fold_right
          (fun e1 (mem, l1) ->
            if e1.efam_name = e.efam_name then
              match e1.efam_name with
              | Efam_Marriage | Efam_NoMarriage | Efam_NoMention ->
                  if !found_marriage then (mem, e1 :: l1)
                  else if e.efam_name = e1.efam_name && can_merge_event e e1
                  then
                    let date =
                      field e.efam_date e1.efam_date (( = ) Date.cdate_None)
                    in
                    let place = field e.efam_place e1.efam_place (( = ) "") in
                    let note =
                      merge_strings e.efam_note "<br>\n" e1.efam_note
                    in
                    let src = merge_strings e.efam_src ", " e1.efam_src in
                    let witnesses =
                      merge_event_witnesses e1.efam_witnesses e.efam_witnesses
                    in
                    let e1 =
                      {
                        e1 with
                        efam_date = date;
                        efam_place = place;
                        efam_note = note;
                        efam_src = src;
                        efam_witnesses = witnesses;
                      }
                    in
                    let _ = found_marriage := true in
                    (true, e1 :: l1)
                  else (mem, e1 :: l1)
              | Efam_Annulation | Efam_Divorce | Efam_Separated ->
                  if !found_divorce then (mem, e1 :: l1)
                  else if e.efam_name = e1.efam_name && can_merge_event e e1
                  then
                    let date =
                      field e.efam_date e1.efam_date (( = ) Date.cdate_None)
                    in
                    let place = field e.efam_place e1.efam_place (( = ) "") in
                    let note =
                      merge_strings e.efam_note "<br>\n" e1.efam_note
                    in
                    let src = merge_strings e.efam_src ", " e1.efam_src in
                    let witnesses =
                      merge_event_witnesses e1.efam_witnesses e.efam_witnesses
                    in
                    let e1 =
                      {
                        e1 with
                        efam_date = date;
                        efam_place = place;
                        efam_note = note;
                        efam_src = src;
                        efam_witnesses = witnesses;
                      }
                    in
                    let _ = found_marriage := true in
                    (true, e1 :: l1)
                  else (mem, e1 :: l1)
              | _ -> (mem, e1 :: l1)
            else (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 ifam1 fam1 fam2 =
  let field name proj null =
    let x1 = proj fam1 in
    let x2 = proj fam2 in
    match p_getenv conf.env name with
    | Some "1" -> x1
    | Some "2" -> x2
    | _ -> if null x1 then x2 else x1
  in
  let merge_possible_event conv proj =
    let l1 = List.map conv (proj fam1) in
    let l2 = List.map conv (proj fam2) in
    merge_events conf l1 l2
  in
  let fam =
    {
      marriage = field "marriage" get_marriage (( = ) Date.cdate_None);
      marriage_place =
        field "marriage_place"
          (fun f -> sou base (get_marriage_place f))
          (( = ) "");
      marriage_note =
        merge_strings base (get_marriage_note fam1) "<br>\n"
          (get_marriage_note fam2);
      marriage_src =
        merge_strings base (get_marriage_src fam1) ", " (get_marriage_src fam2);
      witnesses = merge_witnesses base (get_witnesses fam1) (get_witnesses fam2);
      relation = field "relation" get_relation (( = ) Married);
      divorce = field "divorce" get_divorce (( = ) NotDivorced);
      fevents =
        merge_possible_event
          (Futil.map_fam_event (sorp base) (sou base))
          get_fevents;
      comment = merge_strings base (get_comment fam1) ", " (get_comment fam2);
      origin_file = sou base (get_origin_file fam1);
      fsources = merge_strings base (get_fsources fam1) ", " (get_fsources fam2);
      fam_index = ifam1;
    }
  in
  let des =
    {
      children =
        Array.map
          (UpdateFam.person_key base)
          (Array.append (get_children fam1) (get_children fam2));
    }
  in
  (fam, des)

let print_merge conf base =
  match (p_getenv conf.env "i", p_getenv conf.env "i2") with
  | Some f1, Some f2 ->
      let ifam1 = ifam_of_string f1 in
      let fam1 = foi base ifam1 in
      let fam2 = foi base (ifam_of_string f2) in
      let sfam, sdes = reconstitute conf base ifam1 fam1 fam2 in
      let digest =
        let ini_sfam = UpdateFam.string_family_of conf base ifam1 in
        Update.digest_family ini_sfam
      in
      let scpl =
        Futil.map_couple_p conf.multi_parents
          (UpdateFam.person_key base)
          (gen_couple_of_family (foi base sfam.fam_index))
      in
      UpdateFam.print_update_fam conf base (sfam, scpl, sdes) digest
  | _ -> Hutil.incorrect_request conf

let print_mod_merge_ok conf base wl cpl des =
  let title _ =
    Output.print_sstring conf (Utf8.capitalize_fst (transl conf "merge done"))
  in
  Hutil.header conf title;
  Hutil.print_link_to_welcome conf true;
  UpdateFamOk.print_family conf base wl cpl des;
  MergeDisplay.print_possible_continue_merging conf base;
  Hutil.trailer conf

let effective_mod_merge conf base o_f1 o_f2 sfam scpl sdes =
  match p_getenv conf.env "i2" with
  | None -> Hutil.incorrect_request conf
  | Some i2 ->
      let ifam2 = ifam_of_string i2 in
      UpdateFamOk.effective_del conf base Gwdb.dummy_iper (foi base ifam2);
      let ifam, fam, cpl, des =
        UpdateFamOk.effective_mod conf base true sfam scpl sdes
      in
      let wl =
        UpdateFamOk.all_checks_family conf base ifam fam cpl des
          (scpl, sdes, None)
      in
      Util.commit_patches conf base;
      let s =
        let sl =
          [ fam.comment; fam.fsources; fam.marriage_note; fam.marriage_src ]
        in
        let sl =
          let rec loop l accu =
            match l with
            | [] -> accu
            | evt :: l -> loop l (evt.efam_note :: evt.efam_src :: accu)
          in
          loop fam.fevents sl
        in
        String.concat " " (List.map (sou base) sl)
      in
      Notes.update_notes_links_db base (Def.NLDB.PgFam ifam) s;
      let changed =
        let gen_p =
          let p =
            match p_getenv conf.env "ip" with
            | Some i ->
                let ip = iper_of_string i in
                if Adef.mother cpl = ip then poi base (Adef.mother cpl)
                else poi base (Adef.father cpl)
            | None -> poi base (Adef.father cpl)
          in
          Util.string_gen_person base (gen_person_of_person p)
        in
        let n_f = Util.string_gen_family base fam in
        U_Merge_family (gen_p, o_f1, o_f2, n_f)
      in
      History.record conf base changed "ff";
      print_mod_merge_ok conf base wl cpl des

let print_mod_merge o_conf base =
  let get_gen_family i =
    match p_getenv o_conf.env i with
    | Some i ->
        let fam = foi base (ifam_of_string i) in
        Util.string_gen_family base (gen_family_of_family fam)
    | None ->
        let fam = foi base dummy_ifam in
        Util.string_gen_family base (gen_family_of_family fam)
  in
  let o_f1 = get_gen_family "i" in
  let o_f2 = get_gen_family "i2" in
  let conf = Update.update_conf o_conf in
  UpdateFamOk.print_mod_aux conf base (effective_mod_merge conf base o_f1 o_f2)
