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

open Config
open Def
open Gwdb
open Util
open Dag2html
open Relation

let dag_of_ind_dag_list indl =
  let indl, _ =
    List.fold_right
      (fun ind (indl, cnt) -> ((ind, cnt) :: indl, cnt + 1))
      indl ([], 0)
  in
  let idag_of_di_ind ind = idag_of_int (List.assq ind indl) in
  List.map
    (fun (ind, cnt) ->
      {
        pare = List.map idag_of_di_ind ind.di_famc.df_pare;
        valu =
          (match ind.di_val with
          | Some ic -> Def.Left ic
          | None -> Def.Right cnt);
        chil = List.map idag_of_di_ind ind.di_fams.df_chil;
      })
    indl

let dag_of_relation_path conf base path =
  let indl = dag_ind_list_of_path path in
  let indl = add_missing_parents_of_siblings conf base indl in
  let faml = dag_fam_list_of_ind_list indl in
  let indl = add_phony_children indl faml in
  let nl = dag_of_ind_dag_list indl in
  let d = { dag = Array.of_list (List.rev nl) } in
  let set =
    List.fold_left
      (fun set n ->
        match n.valu with
        | Def.Left ip -> Dag.Pset.add ip set
        | Def.Right _ -> set)
      Dag.Pset.empty nl
  in
  (set, d)

let old_print_relationship_dag conf base elem_txt vbar_txt path next_txt =
  let invert = Util.p_getenv conf.env "invert" = Some "on" in
  let set, d = dag_of_relation_path conf base path in
  let page_title =
    transl conf "relationship" |> Utf8.capitalize_fst |> Adef.safe
  in
  let hts =
    DagDisplay.make_tree_hts conf base elem_txt vbar_txt invert set [] d
  in
  DagDisplay.print_slices_menu_or_dag_page conf base page_title hts next_txt

let print_relationship_dag conf base elem_txt vbar_txt path next_txt =
  if p_getenv conf.env "new" <> Some "on" then
    old_print_relationship_dag conf base elem_txt vbar_txt path next_txt
  else
    let invert = Util.p_getenv conf.env "invert" = Some "on" in
    let set = ind_set_of_relation_path base path in
    let page_title =
      transl conf "relationship" |> Utf8.capitalize_fst |> Adef.safe
    in
    DagDisplay.make_and_print_dag conf base elem_txt vbar_txt invert set []
      page_title next_txt

let next_relation_link_txt conf ip1 ip2 excl_faml : Adef.escaped_string =
  let bd =
    match p_getenv conf.env "bd" with
    | None | Some ("0" | "") -> Adef.escaped ""
    | Some x -> "&bd=" ^<^ (Mutil.encode x :> Adef.escaped_string)
  in
  let color =
    match p_getenv conf.env "color" with
    | None -> Adef.escaped ""
    | Some x -> "&color=" ^<^ (Mutil.encode x :> Adef.escaped_string)
  in
  let sl, _ =
    List.fold_left
      (fun (sl, i) ifam ->
        ("&ef" ^ string_of_int i ^ "=" ^ string_of_ifam ifam ^ sl, i - 1))
      ("", List.length excl_faml - 1)
      excl_faml
  in
  commd conf ^^^ "em=R&ei=" ^<^ string_of_iper ip1 ^<^ "&i="
  ^<^ string_of_iper ip2
  ^<^ (if p_getenv conf.env "spouse" = Some "on" then "&spouse=on" else "")
  ^<^ bd ^^^ color ^>^ "&et=S" ^ sl

let print_relation_path conf base ip1 ip2 path ifam excl_faml =
  if path = [] then (
    let title _ =
      transl conf "relationship" |> Utf8.capitalize_fst
      |> Output.print_sstring conf
    in
    Hutil.header_no_page_title conf title;
    Hutil.trailer conf)
  else
    let next_txt = next_relation_link_txt conf ip1 ip2 (ifam :: excl_faml) in
    let elem_txt p = DagDisplay.Item (p, Adef.safe "") in
    let vbar_txt ip =
      let u = pget conf base ip in
      let excl_faml = Array.to_list (get_family u) @ excl_faml in
      next_relation_link_txt conf ip1 ip2 excl_faml
    in
    print_relationship_dag conf base elem_txt vbar_txt path next_txt

let print_shortest_path conf base p1 p2 =
  let ip1 = get_iper p1 in
  let ip2 = get_iper p2 in
  if ip1 = ip2 then (
    let title _ =
      transl conf "relationship" |> Utf8.capitalize_fst
      |> Output.print_sstring conf
    in
    Hutil.header conf title;
    transl conf "it is the same person!"
    |> Utf8.capitalize_fst |> Output.print_sstring conf;
    Output.print_sstring conf "\n";
    Hutil.trailer conf)
  else
    let excl_faml = excl_faml conf base in
    let title _ =
      transl conf "relationship" |> Utf8.capitalize_fst
      |> Output.print_sstring conf
    in
    match get_shortest_path_relation conf base ip1 ip2 excl_faml with
    | Some (path, ifam) ->
        print_relation_path conf base ip1 ip2 path ifam excl_faml
    | None ->
        let s1 = gen_person_title_text reference conf base p1 in
        let s2 = gen_person_title_text reference conf base p2 in
        Hutil.header_no_page_title conf title;
        if excl_faml = [] then (
          Output.print_sstring conf "<h1>";
          title false;
          Output.print_sstring conf "</h1>";
          Hutil.print_link_to_welcome conf true;
          ([ s1; s2 ] : Adef.safe_string list :> string list)
          |> cftransl conf "no known relationship link between %s and %s"
          |> Utf8.capitalize_fst |> Output.print_sstring conf;
          Output.print_sstring conf ".<br><p><span><a href=\"";
          Output.print_string conf (commd conf);
          Output.print_sstring conf "&m=R&";
          Output.print_string conf (acces conf base p1);
          Output.print_sstring conf "\">";
          transl_nth conf "try another/relationship computing" 0
          |> Utf8.capitalize_fst |> Output.print_sstring conf;
          Output.print_sstring conf "</a> ";
          transl_nth conf "try another/relationship computing" 1
          |> Output.print_sstring conf;
          Output.print_sstring conf "</span></p>")
        else (
          Output.print_sstring conf "<ul><li>";
          Output.print_string conf s1;
          Output.print_sstring conf "</li><li>";
          Output.print_string conf s2;
          Output.print_sstring conf "</ul>");
        Hutil.trailer conf

let parents_label conf base info = function
  | 1 -> transl conf "the parents" |> Adef.safe
  | 2 ->
      let txt = transl conf "grand-parents" in
      let is =
        if nb_fields txt = 2 then
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] -> if get_sex (pget conf base ip1) = Male then 0 else 1
          | _ -> (* must be a bug *) 0
        else 0
      in
      nth_field txt is |> Adef.safe
  | 3 ->
      let txt = transl conf "great-grand-parents" in
      let is =
        if nb_fields txt = 2 then
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] -> if get_sex (pget conf base ip1) = Male then 0 else 1
          | _ -> (* must be a bug *) 0
        else 0
      in
      nth_field txt is |> Adef.safe
  | n ->
      transl conf "ancestors (some)"
      ^ " "
      ^ Printf.sprintf
          (ftransl conf "of the %s generation")
          (transl_nth conf "nth (generation)" n)
      |> Adef.safe

let parent_in_law_label conf child_sex parent_sex =
  let txt = transl conf "the father-in-law/the mother-in-law" in
  let is = index_of_sex parent_sex in
  if nb_fields txt = 2 then nth_field txt is |> Adef.safe
  else nth_field txt ((2 * index_of_sex child_sex) + is) |> Adef.safe

let ancestor_label conf base info x sex =
  let is = index_of_sex sex in
  match x with
  | 1 -> transl_nth conf "the father/the mother/a parent" is |> Adef.safe
  | 2 ->
      let txt = transl conf "a grandfather/a grandmother/a grandparent" in
      let is =
        if nb_fields txt = 6 then
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] ->
              if get_sex (pget conf base ip1) = Male then is else is + 3
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | 3 ->
      let txt =
        transl conf
          "a great-grandfather/a great-grandmother/a great-grandparent"
      in
      let is =
        if nb_fields txt = 6 then
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] ->
              if get_sex (pget conf base ip1) = Male then is else is + 3
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | n ->
      transl_nth conf "an ancestor" is
      ^ " "
      ^ Printf.sprintf
          (ftransl conf "of the %s generation")
          (transl_nth conf "nth (generation)" n)
      |> Adef.safe

let child_in_law_label conf sex_child sex_parent =
  let txt = transl conf "a son-in-law/a daughter-in-law" in
  let is = index_of_sex sex_child in
  if nb_fields txt = 2 then nth_field txt is |> Adef.safe
  else nth_field txt ((2 * index_of_sex sex_parent) + is) |> Adef.safe

let descendant_label conf base info x p =
  let is = index_of_sex (get_sex p) in
  match x with
  | 1 -> transl_nth conf "a son/a daughter/a child" is |> Adef.safe
  | 2 ->
      let txt = transl conf "a grandson/a granddaughter/a grandchild" in
      let is =
        if nb_fields txt = 6 then
          let info = (info, fun r -> r.Consang.lens2) in
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] ->
              if get_sex (pget conf base ip1) = Male then is else is + 3
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | 3 ->
      let txt =
        transl conf "a great-grandson/a great-granddaughter/a great-grandchild"
      in
      let is =
        if nb_fields txt = 12 then
          let info = (info, fun r -> r.Consang.lens2) in
          match get_piece_of_branch conf base info (1, 2) with
          | [ ip1; ip2 ] ->
              let is =
                if get_sex (pget conf base ip1) = Male then is else is + 6
              in
              if get_sex (pget conf base ip2) = Male then is else is + 3
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | n ->
      transl_nth conf "a descendant" is
      ^ " "
      ^ Printf.sprintf
          (ftransl conf "of the %s generation")
          (transl_nth conf "nth (generation)" n)
      |> Adef.safe

let brother_label conf x sex : Adef.safe_string =
  let is = index_of_sex sex in
  match x with
  | 1 -> transl_nth conf "a brother/a sister/a sibling" is |> Adef.safe
  | 2 -> transl_nth conf "a cousin" is |> Adef.safe
  | 3 -> transl_nth conf "a 2nd cousin" is |> Adef.safe
  | 4 -> transl_nth conf "a 3rd cousin" is |> Adef.safe
  | n ->
      Printf.sprintf
        (ftransl_nth conf "a %s cousin" is)
        (transl_nth conf "nth (cousin)" (n - 1))
      |> Adef.safe

let half_brother_label conf sex =
  index_of_sex sex
  |> transl_nth conf "a half-brother/a half-sister/a half-sibling"
  |> Adef.safe

let brother_in_law_label conf brother_sex self_sex =
  let txt = transl conf "a brother-in-law/a sister-in-law" in
  let is = index_of_sex brother_sex in
  if nb_fields txt = 2 then nth_field txt is |> Adef.safe
  else nth_field txt ((2 * index_of_sex self_sex) + is) |> Adef.safe

let uncle_label conf base info x p =
  let is = index_of_sex (get_sex p) in
  match x with
  | 1 ->
      let txt = transl conf "an uncle/an aunt" in
      let is =
        if nb_fields txt = 4 then
          let info = (info, fun r -> r.Consang.lens1) in
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] ->
              if get_sex (pget conf base ip1) = Male then is else is + 2
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | 2 ->
      let txt = transl conf "a great-uncle/a great-aunt" in
      let is =
        if nb_fields txt = 4 then
          let info = (info, fun r -> r.Consang.lens1) in
          match get_piece_of_branch conf base info (1, 1) with
          | [ ip1 ] ->
              if get_sex (pget conf base ip1) = Male then is else is + 2
          | _ -> (* must be a bug *) is
        else is
      in
      nth_field txt is |> Adef.safe
  | n ->
      transl_nth conf "an uncle/an aunt" is
      ^ " "
      ^ Printf.sprintf
          (ftransl conf "of the %s generation")
          (transl_nth conf "nth (generation)" n)
      |> Adef.safe

let nephew_label conf x p =
  let is = index_of_sex (get_sex p) in
  match x with
  | 1 -> transl_nth conf "a nephew/a niece" is |> Adef.safe
  | 2 -> transl_nth conf "a great-nephew/a great-niece" is |> Adef.safe
  | n ->
      transl_nth conf "a nephew/a niece" is
      ^ " "
      ^ Printf.sprintf
          (ftransl conf "of the %s generation")
          (transl_nth conf "nth (generation)" n)
      |> Adef.safe

let same_parents conf base p1 p2 =
  get_parents (pget conf base (get_iper p1))
  = get_parents (pget conf base (get_iper p2))

let print_link_name conf base n p1 p2 sol =
  let pp1, pp2, (x1, x2, list), reltab = sol in
  let info = (reltab, list) in
  if is_hide_names conf p2 && not (authorized_age conf base p2) then
    Output.print_sstring conf "x x"
  else Output.print_string conf @@ person_title_text conf base p2;
  Output.print_sstring conf " ";
  Output.print_sstring conf (transl conf "is");
  if n > 1 then (
    Output.print_sstring conf " ";
    Output.print_sstring conf (transl conf "also");
    Output.print_sstring conf " ")
  else Output.print_sstring conf " ";
  let s, sp1, sp2 =
    let ini_p1 = p1 and ini_p2 = p2 in
    let p1 = match pp1 with Some p1 -> p1 | _ -> p1 in
    let p2 = match pp2 with Some p2 -> p2 | _ -> p2 in
    let sp1 = pp1 <> None in
    let sp2 = pp2 <> None in
    if x2 = 0 then
      if sp1 && x1 = 1 then
        (parent_in_law_label conf (get_sex ini_p1) (get_sex ini_p2), false, sp2)
      else
        let info = ((info, x1), fun r -> r.Consang.lens1) in
        (ancestor_label conf base info x1 (get_sex p2), sp1, sp2)
    else if x1 = 0 then
      if sp2 && x2 = 1 then
        (child_in_law_label conf (get_sex ini_p2) (get_sex ini_p1), sp1, false)
      else (descendant_label conf base (info, x2) x2 p2, sp1, sp2)
    else if x2 = x1 then
      if x2 = 1 && not (same_parents conf base p2 p1) then
        (half_brother_label conf (get_sex p2), sp1, sp2)
      else if x2 = 1 && (sp2 || sp1) && get_sex p2 <> Neuter then
        ( brother_in_law_label conf (get_sex ini_p2) (get_sex ini_p1),
          false,
          false )
      else (brother_label conf x1 (get_sex p2), sp1, sp2)
    else if x2 = 1 then (uncle_label conf base (info, x1) (x1 - x2) p2, sp1, sp2)
    else if x1 = 1 then (nephew_label conf (x2 - x1) p2, sp1, sp2)
    else if x2 < x1 then
      let s =
        let info = ((info, x1), fun r -> r.Consang.lens1) in
        let s = ancestor_label conf base info (x1 - x2) Neuter in
        transl_a_of_gr_eq_gen_lev conf
          (brother_label conf x2 (get_sex p2) : Adef.safe_string :> string)
          (s : Adef.safe_string :> string)
          (s : Adef.safe_string :> string)
        |> Adef.safe
      in
      (s, sp1, sp2)
    else
      let s =
        let sm = brother_label conf x1 Male in
        let sf = brother_label conf x1 Female in
        let d = descendant_label conf base (info, x2) (x2 - x1) p2 in
        let s =
          if sm = sf then sm
          else
            let info = ((info, x2), fun r -> r.Consang.lens2) in
            match get_piece_of_branch conf base info (x2 - x1, x2 - x1) with
            | [ ip2 ] -> if get_sex (pget conf base ip2) = Male then sm else sf
            | _ -> sm
        in
        transl_a_of_gr_eq_gen_lev conf
          (d : Adef.safe_string :> string)
          (s : Adef.safe_string :> string)
          (s : Adef.safe_string :> string)
        |> Adef.safe
      in
      (s, sp1, sp2)
  in
  let s =
    if sp2 then
      transl_a_of_gr_eq_gen_lev conf
        (transl_nth conf "the spouse" (index_of_sex (get_sex p2)))
        (s : Adef.safe_string :> string)
        (s : Adef.safe_string :> string)
      |> Adef.safe
    else s
  in
  let s =
    if sp1 then
      match pp1 with
      | Some pp1 ->
          let s' =
            get_sex pp1 |> index_of_sex
            |> transl_nth conf "the spouse"
            |> Adef.safe
          in
          transl_a_of_gr_eq_gen_lev conf
            (s : Adef.safe_string :> string)
            (s' : Adef.safe_string :> string)
            (s' : Adef.safe_string :> string)
          |> Adef.safe
      | None -> s
    else s
  in
  let s1 = "<strong>" ^<^ std_color conf s ^>^ "</strong>" in
  let s2 =
    if is_hide_names conf p1 && not (authorized_age conf base p1) then
      Adef.safe "x x"
    else gen_person_title_text no_reference conf base p1
  in
  let s =
    if x2 < x1 then
      transl_a_of_b conf
        (s1 : Adef.safe_string :> string)
        (s2 : Adef.safe_string :> string)
        (s2 : Adef.safe_string :> string)
      |> Adef.safe
    else
      transl_a_of_gr_eq_gen_lev conf
        (s1 : Adef.safe_string :> string)
        (s2 : Adef.safe_string :> string)
        (s2 : Adef.safe_string :> string)
      |> Adef.safe
  in
  Util.translate_eval (s :> string) |> Output.print_sstring conf;
  Output.print_sstring conf ".\n"

let string_of_big_int conf i =
  let sep = transl conf "(thousand separator)" in
  let rec glop i =
    if i = 0 then ""
    else
      let s = glop (i / 1000) in
      if s = "" then string_of_int (i mod 1000)
      else s ^ sep ^ Printf.sprintf "%03d" (i mod 1000)
  in
  glop i

let print_solution_ancestor conf base long p1 p2 pp1 pp2 x1 x2 list =
  let image_opt =
    Adef.escaped
    @@
    if
      p_getenv conf.env "im" = Some "off"
      || p_getenv conf.env "image" = Some "off"
    then "&im=off"
    else ""
  in
  Output.print_sstring conf "<ul>";
  List.iter
    (fun (a, n) ->
      Output.print_sstring conf "<li>";
      Output.print_sstring conf "<em>";
      Output.print_sstring conf
        (if n < 0 then "***" else string_of_big_int conf n);
      Output.print_sstring conf " ";
      Output.print_sstring conf
        (transl_nth conf "branch/branches" (if n = 1 then 0 else 1));
      Output.print_sstring conf "</em>\n";
      if not long then (
        let propose_dag = n > 1 && n <= 10 in
        Output.print_sstring conf ":\n ";
        let dp1 = match pp1 with Some p -> p | _ -> p1 in
        let dp2 = match pp2 with Some p -> p | _ -> p2 in
        Output.print_sstring conf "<img src=\"";
        Output.print_string conf (Image.prefix conf);
        Output.print_sstring conf "/picto_rel_small.png\" alt=\"\">";
        let href =
          commd conf ^^^ "m=RL&" ^<^ acces conf base a ^^^ "&l1="
          ^<^ string_of_int x1 ^<^ "&"
          ^<^ acces_n conf base (Adef.escaped "1") dp1
          ^^^ "&l2=" ^<^ string_of_int x2 ^<^ "&"
          ^<^ acces_n conf base (Adef.escaped "2") dp2
          ^^^ (if pp1 = None then Adef.escaped ""
              else "&" ^<^ acces_n conf base (Adef.escaped "3") p1)
          ^^^ (if pp2 = None then Adef.escaped ""
              else "&" ^<^ acces_n conf base (Adef.escaped "4") p2)
          ^^^ (if propose_dag then Adef.escaped "&dag=on" else Adef.escaped "")
          ^^^ image_opt
        in
        Output.print_sstring conf {|<a href="|};
        Output.print_string conf href;
        Output.print_sstring conf {|">|};
        transl conf "see" |> Utf8.capitalize_fst |> Output.print_sstring conf;
        if n > 1 && not propose_dag then
          Output.print_sstring conf (transl conf " the first branch");
        Output.print_sstring conf "</a>");
      Output.print_sstring conf "</li>")
    list;
  Output.print_sstring conf "</ul>"

let print_solution_not_ancestor conf base long p1 p2 sol =
  let pp1, pp2, (x1, x2, list), reltab = sol in
  let image_opt =
    Adef.escaped
    @@
    if
      p_getenv conf.env "im" = Some "off"
      || p_getenv conf.env "image" = Some "off"
    then "&im=off"
    else ""
  in
  Output.print_sstring conf {|<ul class="li_relationship"><li>|};
  transl conf "indeed," |> Utf8.capitalize_fst |> Output.print_sstring conf;
  Output.print_sstring conf " <ul>";
  List.iter
    (fun (a, n) ->
      Output.print_sstring conf "<li>\n";
      Output.print_string conf (person_title_text conf base a);
      Output.print_sstring conf "\n<em>(";
      Output.print_sstring conf (string_of_int n);
      Output.print_sstring conf " ";
      (if n = 1 then 0 else 1)
      |> transl_nth conf "relationship link/relationship links"
      |> Output.print_sstring conf;
      Output.print_sstring conf ")</em> &nbsp;";
      if not long then (
        let propose_dag = n > 1 && n <= 10 in
        let dp1 = match pp1 with Some p -> p | _ -> p1 in
        let dp2 = match pp2 with Some p -> p | _ -> p2 in
        Output.print_sstring conf {|<img src="|};
        Output.print_string conf (Image.prefix conf);
        Output.print_sstring conf {|/picto_rel_small.png" alt="">|};
        let href =
          commd conf ^^^ "m=RL&" ^<^ acces conf base a ^^^ "&l1="
          ^<^ string_of_int x1 ^<^ "&"
          ^<^ acces_n conf base (Adef.escaped "1") dp1
          ^^^ "&l2=" ^<^ string_of_int x2 ^<^ "&"
          ^<^ acces_n conf base (Adef.escaped "2") dp2
          ^^^ (if pp1 = None then Adef.escaped ""
              else "&" ^<^ acces_n conf base (Adef.escaped "3") p1)
          ^^^ (if pp2 = None then Adef.escaped ""
              else "&" ^<^ acces_n conf base (Adef.escaped "4") p2)
          ^^^ (if propose_dag then Adef.escaped "&dag=on" else Adef.escaped "")
          ^^^ image_opt
        in
        Output.print_sstring conf {|<a href="|};
        Output.print_string conf href;
        Output.print_sstring conf {|">|};
        transl conf "see" |> Utf8.capitalize_fst |> Output.print_sstring conf;
        Output.print_sstring conf "</a>");
      Output.print_sstring conf "</li>")
    list;
  Output.print_sstring conf "</ul>";
  let is_are =
    match list with [ _ ] -> transl conf "is" | _ -> transl conf "are"
  in
  Output.print_sstring conf is_are;
  Output.print_sstring conf " ";
  Output.print_sstring conf (transl conf "at the same time");
  Output.print_sstring conf " ";
  let lab proj x =
    let info = (((reltab, list), x), proj) in
    match list with
    | [ (a, _) ] -> ancestor_label conf base info x (get_sex a)
    | _ -> parents_label conf base info x
  in
  let print pp p (alab : Adef.safe_string) =
    let s = gen_person_title_text no_reference conf base p in
    let s =
      match pp with
      | None -> transl_a_of_b conf (alab :> string) (s :> string) (s :> string)
      | Some pp ->
          transl_a_of_gr_eq_gen_lev conf
            (let s = transl_nth conf "the spouse" (index_of_sex (get_sex pp)) in
             transl_a_of_b conf (alab :> string) s s)
            (s :> string)
            (s :> string)
    in
    Output.print_sstring conf (Util.translate_eval s)
  in
  Output.print_sstring conf "<ul><li>";
  print pp1 p1 (lab (fun r -> r.Consang.lens1) x1);
  Output.print_sstring conf "</li><li>";
  print pp2 p2 (lab (fun r -> r.Consang.lens2) x2);
  Output.print_sstring conf "</li></ul></li></ul>"

let print_solution conf base long n p1 p2 sol =
  let pp1, pp2, (x1, x2, list), _ = sol in
  Output.print_sstring conf {|<p><img src="|};
  Output.print_string conf (Image.prefix conf);
  Output.print_sstring conf {|/picto_fleche_bleu.png" alt="">|};
  print_link_name conf base n p1 p2 sol;
  Output.print_sstring conf "</p>\n";
  if x1 = 0 || x2 = 0 then
    print_solution_ancestor conf base long p1 p2 pp1 pp2 x1 x2 list
  else print_solution_not_ancestor conf base long p1 p2 sol;
  Output.print_sstring conf "\n"

let max_br = 33

let print_dag_links conf base p1 p2 rl =
  let module O = struct
    type t = iper

    let compare = compare
  end in
  let module M = Map.Make (O) in
  let anc_map =
    List.fold_left
      (fun anc_map (pp1, pp2, (x1, x2, list), _) ->
        List.fold_left
          (fun anc_map (p, n) ->
            let pp1, pp2, nn, nt, maxlev =
              try M.find (get_iper p) anc_map
              with Not_found -> (pp1, pp2, 0, 0, 0)
            in
            if nn >= max_br then anc_map
            else
              let v = (pp1, pp2, nn + n, nt + 1, max maxlev (max x1 x2)) in
              M.add (get_iper p) v anc_map)
          anc_map list)
      M.empty rl
  in
  let is_anc =
    match rl with (_, _, (x1, x2, _), _) :: _ -> x1 = 0 || x2 = 0 | _ -> false
  in
  let something =
    M.fold
      (fun _ (_, _, nn, nt, _) something ->
        something || (nt > 1 && nn > 1 && nn < max_br))
      anc_map false
  in
  if something then (
    let rest = ref false in
    if is_anc then (
      Output.print_sstring conf {|<img src="|};
      Output.print_string conf (Image.prefix conf);
      Output.print_sstring conf {|/picto_fleche_bleu.png" alt="">|})
    else Output.print_sstring conf "<ul>";
    M.iter
      (fun ip (pp1, pp2, nn, nt, _) ->
        let dp1 = match pp1 with Some p -> p | _ -> p1 in
        let dp2 = match pp2 with Some p -> p | _ -> p2 in
        if nt > 1 && nn > 1 && nn < max_br then (
          let a = pget conf base ip in
          if not is_anc then (
            Output.print_sstring conf "<li>";
            Output.print_string conf (person_title_text conf base a);
            Output.print_sstring conf (Util.transl conf ":");
            Output.print_sstring conf " ");
          Output.print_sstring conf "<a href=\"";
          Output.print_string conf (commd conf);
          Output.print_sstring conf "m=RL&";
          Output.print_string conf (acces conf base a);
          Output.print_sstring conf "&";
          Output.print_string conf (acces_n conf base (Adef.escaped "1") dp1);
          Output.print_sstring conf "&";
          Output.print_string conf (acces_n conf base (Adef.escaped "2") dp2);
          if pp1 <> None then (
            Output.print_sstring conf "&";
            Output.print_string conf (acces_n conf base (Adef.escaped "3") p1));
          if pp2 <> None then (
            Output.print_sstring conf "&";
            Output.print_string conf (acces_n conf base (Adef.escaped "4") p2));
          let l1, l2 =
            List.fold_left
              (fun (l1, l2) (_, _, (x1, x2, list), _) ->
                List.fold_left
                  (fun (l1, l2) (a, _) ->
                    if get_iper a = ip then
                      let l1 = if List.mem x1 l1 then l1 else x1 :: l1 in
                      let l2 = if List.mem x2 l2 then l2 else x2 :: l2 in
                      (l1, l2)
                    else (l1, l2))
                  (l1, l2) list)
              ([], []) rl
          in
          Output.print_sstring conf "&l1=";
          List.iteri
            (fun i x ->
              if i <> 0 then Output.print_sstring conf ",";
              Output.print_sstring conf (string_of_int x))
            l1;
          Output.print_sstring conf "&l2=";
          List.iteri
            (fun i x ->
              if i <> 0 then Output.print_sstring conf ",";
              Output.print_sstring conf (string_of_int x))
            l2;
          if
            p_getenv conf.env "im" = Some "off"
            || p_getenv conf.env "image" = Some "off"
          then Output.print_sstring conf "&im=off";
          if p_getenv conf.env "bd" = Some "on" then
            Output.print_sstring conf "&bd=on";
          Output.print_sstring conf {|&dag=on">|};
          if is_anc then Output.print_sstring conf (transl conf "tree")
          else (
            Output.print_sstring conf (string_of_int nn);
            Output.print_sstring conf " ";
            Output.print_sstring conf
              (transl_nth conf "relationship link/relationship links" 1));
          Output.print_sstring conf "</a>";
          if not is_anc then Output.print_sstring conf "</li>" else rest := true))
      anc_map;
    if !rest then Output.print_sstring conf "<li>...</li>";
    if is_anc then Output.print_sstring conf "\n"
    else Output.print_sstring conf "</ul>\n")

let print_propose_upto conf base p1 p2 rl =
  match rl with
  | (None, None, (x1, x2, _), _) :: _ when x1 = 0 || x2 = 0 ->
      let maxlen =
        List.fold_right
          (fun (_, _, (x1, x2, _), _) maxlen -> max maxlen (max x1 x2))
          rl 0
      in
      let p, a = if x1 = 0 then (p2, p1) else (p1, p2) in
      Output.print_sstring conf {|<p><img src="|};
      Output.print_string conf (Image.prefix conf);
      Output.print_sstring conf
        {|/picto_fleche_bleu.png" alt=""> <span class="smaller">|};
      let s = (person_title_text conf base p : Adef.safe_string :> string) in
      transl_a_of_b conf (transl_nth conf "ancestor/ancestors" 1) s s
      |> translate_eval |> Utf8.capitalize_fst |> Output.print_sstring conf;
      Output.print_sstring conf " ";
      (person_title_text conf base a : Adef.safe_string :> string)
      |> transl_decline conf "up to"
      |> Output.print_sstring conf;
      Output.print_sstring conf {|&nbsp;<img src="|};
      Output.print_string conf (Image.prefix conf);
      Output.print_sstring conf {|/picto_rel_asc.png" alt=""> <a href="|};
      Output.print_string conf (commd conf);
      Output.print_string conf (acces conf base p);
      Output.print_sstring conf "&m=A&t=D&";
      Output.print_string conf (acces_n conf base (Adef.escaped "1") a);
      Output.print_sstring conf "&l=";
      Output.print_sstring conf (string_of_int maxlen);
      Output.print_sstring conf {|">|};
      transl conf "see" |> Utf8.capitalize_fst |> Output.print_sstring conf;
      Output.print_sstring conf "</a></span></p>"
  | _ -> ()

let print_one_path conf base found a p1 p2 pp1 pp2 l1 l2 =
  let ip = get_iper a in
  let sp1 = match pp1 with Some _ -> Some p1 | _ -> None in
  let sp2 = match pp2 with Some _ -> Some p2 | _ -> None in
  let p1 = match pp1 with Some p1 -> p1 | _ -> p1 in
  let p2 = match pp2 with Some p2 -> p2 | _ -> p2 in
  let ip1 = get_iper p1 in
  let ip2 = get_iper p2 in
  let dist = RelationLink.make_dist_tab conf base ip (max l1 l2 + 1) in
  let b1 = RelationLink.find_first_branch conf base dist ip l1 ip1 Neuter in
  let b2 = RelationLink.find_first_branch conf base dist ip l2 ip2 Neuter in
  match (b1, b2) with
  | Some b1, Some b2 ->
      let bd = Option.value ~default:0 (p_getint conf.env "bd") in
      let td_prop =
        match Util.p_getenv conf.env "color" with
        | None | Some "" -> Adef.safe ""
        | Some x ->
            (" class=\"" ^<^ Mutil.encode x ^>^ "\"" :> Adef.safe_string)
      in
      let info =
        RelationLink.
          {
            ip;
            sp = get_sex a;
            ip1;
            ip2;
            b1;
            b2;
            c1 = 1;
            c2 = 1;
            pb1 = None;
            pb2 = None;
            nb1 = None;
            nb2 = None;
            sp1;
            sp2;
            bd;
            td_prop;
          }
      in
      if not (List.mem (b1, b2) !found) then (
        Output.print_sstring conf
          {|<table width="100%"><tr><td align="center"><table><tr><td>|};
        RelationLink.print_relation_path conf base info;
        Output.print_sstring conf {|</td></tr></table></td></tr></table>|};
        found := (b1, b2) :: !found)
  | _ -> ()

let print_path conf base p1 p2 (pp1, pp2, (l1, l2, list), _) =
  let found = ref [] in
  List.iter
    (fun (a, _) -> print_one_path conf base found a p1 p2 pp1 pp2 l1 l2)
    list;
  Output.print_sstring conf "\n"

let print_main_relationship conf base long p1 p2 rel =
  let total =
    match rel with None -> Sosa.zero | Some (_, total, _) -> total
  in
  let title _ =
    transl conf "relationship" |> Utf8.capitalize_fst
    |> Output.print_sstring conf;
    if not (Sosa.eq total Sosa.zero) then (
      Output.print_sstring conf " (";
      Output.print_sstring conf
        (Sosa.to_string_sep (transl conf "(thousand separator)") total);
      Output.print_sstring conf " ";
      (if Sosa.eq total Sosa.one then 0 else 1)
      |> transl_nth conf "relationship link/relationship links"
      |> Output.print_sstring conf;
      Output.print_sstring conf ")")
  in
  Hutil.header conf title;
  Hutil.print_link_to_welcome conf true;
  Util.include_template conf conf.env "buttons_rel" (fun () -> ());
  (match p_getenv conf.env "spouse" with
  | Some "on" -> conf.senv <- conf.senv @ [ ("spouse", Mutil.encode "on") ]
  | _ -> ());
  (match p_getenv conf.env "cgl" with
  | Some "on" -> conf.senv <- conf.senv @ [ ("cgl", Mutil.encode "on") ]
  | _ -> ());
  (match p_getenv conf.env "bd" with
  | None | Some ("0" | "") -> ()
  | Some x -> conf.senv <- conf.senv @ [ ("bd", Mutil.encode x) ]);
  (match p_getenv conf.env "color" with
  | None | Some "" -> ()
  | Some x -> conf.senv <- conf.senv @ [ ("color", Mutil.encode x) ]);
  (match rel with
  | None ->
      if get_iper p1 = get_iper p2 then (
        transl conf "it is the same person!"
        |> Utf8.capitalize_fst |> Output.print_sstring conf;
        Output.print_sstring conf " ")
      else (
        ([
           gen_person_title_text reference conf base p1;
           gen_person_title_text reference conf base p2;
         ]
          : Adef.safe_string list
          :> string list)
        |> cftransl conf "no known relationship link between %s and %s"
        |> Utf8.capitalize_fst |> Output.print_sstring conf;
        Output.print_sstring conf {|.<br><p><span><a href="|};
        Output.print_string conf (commd conf);
        Output.print_sstring conf "&m=R&";
        Output.print_string conf (acces conf base p1);
        Output.print_sstring conf {|">|};
        transl_nth conf "try another/relationship computing" 0
        |> Utf8.capitalize_fst |> Output.print_sstring conf;
        Output.print_sstring conf "</a> ";
        Output.print_sstring conf
          (transl_nth conf "try another/relationship computing" 1);
        Output.print_sstring conf ".</span></p>")
  | Some (rl, _, relationship) ->
      let a1 = p1 in
      let a2 = p2 in
      let all_by_marr =
        List.for_all
          (function Some _, _, _, _ | _, Some _, _, _ -> true | _ -> false)
          rl
      in
      let _ =
        List.fold_left
          (fun i sol ->
            print_solution conf base long i p1 p2 sol;
            if long then print_path conf base p1 p2 sol;
            succ i)
          1 rl
      in
      Output.print_sstring conf "\n";
      if long then () else print_dag_links conf base p1 p2 rl;
      if
        (not all_by_marr)
        && authorized_age conf base p1
        && authorized_age conf base p2
        && get_consang a1 != Adef.fix (-1)
        && get_consang a2 != Adef.fix (-1)
      then (
        Output.print_sstring conf "<p>\n";
        Output.printf conf "<em>%s%s %s%%</em>"
          (Utf8.capitalize_fst (transl conf "relationship"))
          (Util.transl conf ":")
          (string_of_decimal_num conf
             (round_2_dec
                (Adef.float_of_fix (Adef.fix_of_float relationship) *. 100.0)));
        Output.print_sstring conf "</p>\n");
      print_propose_upto conf base p1 p2 rl);
  Hutil.trailer conf

let multi_relation_next_txt conf pl2 lim assoc_txt =
  let assoc_txt : (Gwdb.iper, string) Hashtbl.t = assoc_txt in
  match pl2 with
  | [] -> Adef.escaped ""
  | _ ->
      let acc =
        Adef.escaped (if lim > 0 then "&lim=" ^ string_of_int lim else "")
      in
      let acc =
        List.fold_left
          (fun (acc, n) p ->
            let acc =
              try
                "&t" ^<^ string_of_int n ^<^ "="
                ^<^ (get_iper p |> Hashtbl.find assoc_txt |> Mutil.encode
                      :> Adef.escaped_string)
                ^^^ acc
              with Not_found -> acc
            in
            let acc =
              "&i" ^<^ string_of_int n ^<^ "="
              ^<^ (get_iper p |> string_of_iper |> Mutil.encode
                    :> Adef.escaped_string)
              ^^^ acc
            in
            (acc, n - 1))
          (acc, List.length pl2)
          (List.rev pl2)
        |> fst
      in
      commd conf ^^^ "m=RLM" ^<^ acc

let print_no_relationship conf base pl =
  let title _ =
    transl conf "tree" |> Utf8.capitalize_fst |> Output.print_sstring conf
  in
  Hutil.header conf title;
  Output.print_sstring conf "<ul>";
  List.iter
    (fun p ->
      Output.print_sstring conf "<li>";
      Output.print_string conf (referenced_person_title_text conf base p);
      Output.print_sstring conf "</li>")
    pl;
  Output.print_sstring conf "</ul>";
  Hutil.trailer conf

let print_multi_relation conf base pl lim assoc_txt =
  let assoc_txt : (Gwdb.iper, string) Hashtbl.t = assoc_txt in
  let pl1, pl2 =
    if lim <= 0 then (pl, [])
    else
      let rec loop n rev_pl1 pl2 =
        match (n, pl2) with
        | _, [] | _, [ _ ] -> (pl, [])
        | 0, _ -> (
            match rev_pl1 with
            | p :: _ -> (List.rev rev_pl1, p :: pl2)
            | _ -> (pl, []))
        | n, p :: pl -> loop (n - 1) (p :: rev_pl1) pl
      in
      loop lim [] pl
  in
  let path =
    let rec loop path = function
      | p1 :: (p2 :: _ as pl) -> (
          let ip1 = get_iper p1 in
          let ip2 = get_iper p2 in
          match get_shortest_path_relation conf base ip1 ip2 [] with
          | Some (path1, _) ->
              let path =
                match path with
                | [] -> path1
                | _ -> (
                    match List.rev path1 with
                    | _ :: path1 -> List.rev path1 @ path
                    | [] -> path)
              in
              loop path pl
          | None -> loop path pl)
      | [ _ ] | [] -> path
    in
    loop [] pl1
  in
  if path = [] then print_no_relationship conf base pl
  else
    let elem_txt p =
      DagDisplay.Item
        ( p,
          try
            "<b>("
            ^<^ (get_iper p |> Hashtbl.find assoc_txt |> Util.escape_html
                  :> Adef.safe_string)
            ^>^ ")</b>"
          with Not_found -> Adef.safe "" )
    in
    let vbar_txt _ = Adef.escaped "" in
    let next_txt = multi_relation_next_txt conf pl2 lim assoc_txt in
    print_relationship_dag conf base elem_txt vbar_txt path next_txt

let print_base_loop conf base p =
  let title _ =
    transl conf "error" |> Utf8.capitalize_fst |> Output.print_sstring conf
  in
  Hutil.rheader conf title;
  Output.printf conf
    (fcapitale (ftransl conf "loop in database: %s is his/her own ancestor"))
    (Util.update_family_loop conf base p
       (Util.designation base p : Adef.escaped_string :> Adef.safe_string)
      :> string);
  Output.print_sstring conf ".";
  Hutil.trailer conf

let relmenu_print = Perso.interp_templ "relmenu"

let print conf base p = function
  | Some p1 -> (
      match p_getenv conf.env "et" with
      | Some "S" -> print_shortest_path conf base p1 p
      | x -> (
          let by_marr = x = Some "M" in
          let long =
            match p_getenv conf.env "long" with Some "on" -> true | _ -> false
          in
          match
            try Left (compute_relationship conf base by_marr p1 p)
            with Consang.TopologicalSortError p -> Right p
          with
          | Left rel -> print_main_relationship conf base long p1 p rel
          | Right p -> print_base_loop conf base p))
  | None -> relmenu_print conf base p

let print_multi conf base =
  let assoc_txt : (Gwdb.iper, string) Hashtbl.t = Hashtbl.create 53 in
  let pl =
    let rec loop pl i =
      let k = string_of_int i in
      match find_person_in_env conf base k with
      | Some p ->
          (match p_getenv conf.env ("t" ^ k) with
          | Some x -> Hashtbl.add assoc_txt (get_iper p) x
          | None -> ());
          loop (p :: pl) (i + 1)
      | None -> List.rev pl
    in
    loop [] 1
  in
  let lim = Option.value ~default:0 (p_getint conf.env "lim") in
  print_multi_relation conf base pl lim assoc_txt
