(* Copyright (c) 1999 INRIA *)

open Def
open Gwdb

let all = ref false
let statistics = ref false
let detail = ref 0
let ignore = ref []
let output = ref ""
let ignore_files = ref true
let ask_for_delete = ref 0
let cnt_for_delete = ref 0
let exact = ref false
let gwd_port = ref 2317
let server = ref "127.0.0.1"

let rec merge_families ifaml1f ifaml2f =
  match (ifaml1f, ifaml2f) with
  | ifam1 :: ifaml1, ifam2 :: ifaml2 ->
      let m1 = List.memq ifam1 ifaml2 in
      let m2 = List.memq ifam2 ifaml1 in
      if m1 && m2 then merge_families ifaml1 ifaml2
      else if m1 then ifam2 :: merge_families ifaml1f ifaml2
      else if m2 then ifam1 :: merge_families ifaml1 ifaml2f
      else if ifam1 == ifam2 then ifam1 :: merge_families ifaml1 ifaml2
      else ifam1 :: ifam2 :: merge_families ifaml1 ifaml2
  | ifaml1, [] -> ifaml1
  | [], ifaml2 -> ifaml2

let rec filter f = function
  | x :: l -> if f x then x :: filter f l else filter f l
  | [] -> []

let connected_families base ifam cpl =
  let rec loop ifaml ipl_scanned = function
    | ip :: ipl ->
        if List.memq ip ipl_scanned then loop ifaml ipl_scanned ipl
        else
          let u = poi base ip in
          let ifaml1 = Array.to_list (get_family u) in
          let ifaml = merge_families ifaml ifaml1 in
          let ipl =
            List.fold_right
              (fun ifam ipl ->
                let cpl = foi base ifam in
                get_father cpl :: get_mother cpl :: ipl)
              ifaml1 ipl
          in
          loop ifaml (ip :: ipl_scanned) ipl
    | [] -> ifaml
  in
  loop [ ifam ] [] [ get_father cpl ]

let neighbourgs base ifam =
  let fam = foi base ifam in
  let ifaml = connected_families base ifam fam in
  let ifaml =
    match get_parents (poi base (get_father fam)) with
    | Some ifam -> ifam :: ifaml
    | None -> ifaml
  in
  let ifaml =
    match get_parents (poi base (get_mother fam)) with
    | Some ifam -> ifam :: ifaml
    | None -> ifaml
  in
  List.fold_left
    (fun ifaml ip ->
      let u = poi base ip in
      List.fold_left
        (fun ifaml ifam -> ifam :: ifaml)
        ifaml
        (Array.to_list (get_family u)))
    ifaml
    (Array.to_list (get_children fam))

let utf8_designation base p =
  let first_name = p_first_name base p in
  let surname = p_surname base p in
  let s = first_name ^ "." ^ string_of_int (get_occ p) ^ " " ^ surname in
  if first_name = "?" || surname = "?" then
    s ^ " (i=" ^ string_of_iper (get_iper p) ^ ")"
  else s

let wiki_designation base basename p =
  let first_name = p_first_name base p in
  let surname = p_surname base p in
  let s =
    "[[" ^ first_name ^ "/" ^ surname ^ "/"
    ^ string_of_int (get_occ p)
    ^ "/" ^ first_name ^ "."
    ^ string_of_int (get_occ p)
    ^ " " ^ surname ^ "]]"
  in
  if first_name = "?" || surname = "?" then
    let indx = string_of_iper (get_iper p) in
    s ^ " <a href=\"http://" ^ !server ^ ":" ^ string_of_int !gwd_port ^ "/"
    ^ basename ^ "?i=" ^ indx ^ "\">(i=" ^ indx ^ ")</a><br>"
  else s ^ "<br>"

let print_family base basename ifam =
  let fam = foi base ifam in
  let p = poi base (get_father fam) in
  if !output <> "" then (
    if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?" then
      Printf.eprintf "i=%s" (string_of_iper (get_iper p))
    else Printf.eprintf "  - %s" (utf8_designation base p);
    Printf.eprintf "\n";
    Printf.eprintf "  - %s\n"
      (utf8_designation base (poi base (get_mother fam)));
    flush stderr);
  if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?" then
    let indx = string_of_iper (get_iper p) in
    Printf.printf "  - <a href=\"http://%s:%d/%s?i=%s\">i=%s</a><br>" !server
      !gwd_port basename indx indx
  else Printf.printf "  - %s" (wiki_designation base basename p);
  Printf.printf "\n";
  Printf.printf "  - %s\n"
    (wiki_designation base basename (poi base (get_mother fam)))

let kill_family base ip =
  let u = { family = Array.of_list [] } in
  patch_union base ip u

let kill_parents base ip =
  let a = { parents = None; consang = Adef.fix (-1) } in
  patch_ascend base ip a

let effective_del base (ifam, fam) =
  kill_family base (get_father fam);
  kill_family base (get_mother fam);
  Array.iter (kill_parents base) (get_children fam);
  Gwdb.delete_family base ifam

let move base basename =
  load_ascends_array base;
  load_unions_array base;
  load_couples_array base;
  load_descends_array base;
  Printf.printf "<h3>Connected components of base %s</h3><br>\n" basename;
  let ic = Unix.open_process_in "date" in
  let date = input_line ic in
  let () = close_in ic in
  Printf.printf "Computed on %s<br><br>\n" date;
  flush stderr;
  let mark = Gwdb.ifam_marker (Gwdb.ifams base) false in
  let min = ref max_int in
  let max = ref 0 in
  let hts = Hashtbl.create 100 in
  Gwdb.Collection.iter
    (fun ifam ->
      let fam = foi base ifam in
      let origin_file = get_origin_file fam in
      if List.mem (sou base origin_file) !ignore then ()
      else
        let nb, ifaml =
          let rec loop nb rfaml = function
            | [] -> (nb, rfaml)
            | ifam :: ifaml ->
                let j = ifam in
                if
                  (not (Gwdb.Marker.get mark j))
                  && (!ignore_files || eq_istr (get_origin_file fam) origin_file)
                then (
                  Gwdb.Marker.set mark j true;
                  let nl = neighbourgs base ifam in
                  let rfaml =
                    if nb > !detail then
                      if !ask_for_delete > 0 && nb <= !ask_for_delete then
                        ifam :: rfaml
                      else []
                    else ifam :: rfaml
                  in
                  loop (nb + 1) rfaml (List.rev_append nl ifaml))
                else loop nb rfaml ifaml
          in
          loop 0 [] [ ifam ]
        in
        if nb > 0 && (!all || nb <= !min) then (
          if nb <= !min then min := nb;
          if nb >= !max then max := nb;
          if !output <> "" then (
            Printf.eprintf "Connex component \"%s\" length %d\n"
              (sou base origin_file) nb;
            flush stderr);
          Printf.printf "Connex component \"%s\" length %d<br>\n"
            (sou base origin_file) nb;
          if !detail == nb then List.iter (print_family base basename) ifaml
          else print_family base basename ifam;
          if !statistics then
            match Hashtbl.find_opt hts nb with
            | None -> Hashtbl.add hts nb 1
            | Some n ->
                Hashtbl.replace hts nb (n + 1);
                flush stdout;
                let check_ask =
                  if !exact then nb = !ask_for_delete else nb <= !ask_for_delete
                in
                if !ask_for_delete > 0 && check_ask then (
                  (* if -o file, repeat branch definition to stderr! *)
                  Printf.eprintf "Delete up to %d branches of size %s %d ?\n"
                    !cnt_for_delete
                    (if !exact then "=" else "<=")
                    !ask_for_delete;
                  flush stderr;
                  let r =
                    if !cnt_for_delete > 0 then "y"
                    else (
                      Printf.eprintf "Delete that branch (y/N) ?";
                      flush stderr;
                      input_line stdin)
                  in
                  if r = "y" then (
                    decr cnt_for_delete;
                    List.iter
                      (fun ifam ->
                        let fam = foi base ifam in
                        effective_del base (ifam, fam))
                      ifaml;
                    Printf.eprintf "%d families deleted\n" (List.length ifaml);
                    flush stderr)
                  else (
                    Printf.printf "Nothing done.\n";
                    flush stdout))))
    (Gwdb.ifams base);
  if !ask_for_delete > 0 then Gwdb.commit_patches base;
  if !statistics then (
    Printf.printf "<br>\nStatistics:<br>\n";
    let ls = Hashtbl.fold (fun nb n ls -> (nb, n) :: ls) hts [] in
    let ls = List.sort compare ls in
    let ls = List.rev ls in
    List.iter (fun (nb, n) -> Printf.printf "%d(%d) " nb n) ls;
    Printf.printf "\n")

let bname = ref ""
let usage = "usage: " ^ Sys.argv.(0) ^ " <base>"

let speclist =
  [
    ( "-gwd_p",
      Arg.Int (fun x -> gwd_port := x),
      "<number>: Specify the port number of gwd (default = "
      ^ string_of_int !gwd_port ^ "); > 1024 for normal users." );
    ( "-server",
      Arg.String (fun x -> server := x),
      "<string>: Name of the server (default is 127.0.0.1)." );
    ("-a", Arg.Set all, ": all connex components");
    ("-s", Arg.Set statistics, ": produce statistics");
    ("-d", Arg.Int (fun x -> detail := x), "<int> : detail for this length");
    ( "-i",
      Arg.String (fun x -> ignore := x :: !ignore),
      "<file> : ignore this file" );
    ("-bf", Arg.Clear ignore_files, ": by origin files");
    ( "-del",
      Arg.Int (fun i -> ask_for_delete := i),
      "<int> : ask for deleting branches whose size <= that value" );
    ( "-cnt",
      Arg.Int (fun i -> cnt_for_delete := i),
      "<int> : delete cnt branches whose size <= -del value" );
    ( "-exact",
      Arg.Set exact,
      ": delete only branches whose size strictly = -del value" );
    ("-o", Arg.String (fun x -> output := x), "<file> : output to this file");
  ]

let main () =
  Arg.parse speclist (fun s -> bname := s) usage;
  if !ask_for_delete > 0 then
    Lock.control (Mutil.lock_file !bname) false
      (fun () -> move (Gwdb.open_base !bname) !bname)
      ~onerror:Lock.print_try_again
  else move (Gwdb.open_base !bname) !bname

let _ = main ()