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

open Geneweb
open Def
open Gwdb

let int_of_iper =
  let ht = Hashtbl.create 0 in
  fun i ->
    try Hashtbl.find ht i
    with Not_found ->
      let x = Hashtbl.length ht in
      Hashtbl.add ht i x;
      x

let int_of_ifam =
  let ht = Hashtbl.create 0 in
  fun i ->
    try Hashtbl.find ht i
    with Not_found ->
      let x = Hashtbl.length ht in
      Hashtbl.add ht i x;
      x

let month_txt =
  [|
    "JAN";
    "FEB";
    "MAR";
    "APR";
    "MAY";
    "JUN";
    "JUL";
    "AUG";
    "SEP";
    "OCT";
    "NOV";
    "DEC";
  |]

let french_txt =
  [|
    "VEND";
    "BRUM";
    "FRIM";
    "NIVO";
    "PLUV";
    "VENT";
    "GERM";
    "FLOR";
    "PRAI";
    "MESS";
    "THER";
    "FRUC";
    "COMP";
  |]

let hebrew_txt =
  [|
    "TSH";
    "CSH";
    "KSL";
    "TVT";
    "SHV";
    "ADR";
    "ADS";
    "NSN";
    "IYR";
    "SVN";
    "TMZ";
    "AAV";
    "ELL";
  |]

let ged_month cal m =
  match cal with
  | Dgregorian | Djulian ->
      if m >= 1 && m <= Array.length month_txt then month_txt.(m - 1)
      else failwith "ged_month"
  | Dfrench ->
      if m >= 1 && m <= Array.length french_txt then french_txt.(m - 1)
      else failwith "ged_month"
  | Dhebrew ->
      if m >= 1 && m <= Array.length hebrew_txt then hebrew_txt.(m - 1)
      else failwith "ged_month"

let encode opts s =
  match opts.Gwexport.charset with
  | Gwexport.Ansel -> Ansel.of_iso_8859_1 @@ Mutil.iso_8859_1_of_utf_8 s
  | Gwexport.Ascii | Gwexport.Ansi -> Mutil.iso_8859_1_of_utf_8 s
  | Gwexport.Utf8 -> s

let max_len = 78
let br = "<br>"

let find_br s ini_i =
  let ini = "<br" in
  let rec loop i j =
    if i = String.length ini then
      let rec loop2 j =
        if j = String.length s then br
        else if s.[j] = '>' then String.sub s ini_i (j - ini_i + 1)
        else loop2 (j + 1)
      in
      loop2 j
    else if j = String.length s then br
    else if String.unsafe_get ini i = String.unsafe_get s j then
      loop (i + 1) (j + 1)
    else br
  in
  loop 0 ini_i

let oc opts = match opts.Gwexport.oc with _, oc, _ -> oc

(** [display_note_aux opts tagn s len i] outputs text [s] with CONT/CONC
    tag. GEDCOM lines are limited to 255 characters. However, the
    CONCatenation or CONTinuation tags can be used to expand a field
    beyond this limit. Lines are cut and align with [max_len]
    characters for easy display/printing.
    @see <https://www.familysearch.org/developers/docs/gedcom/> GEDCOM
    STANDARD 5.5, Appendix A CONC and CONT tag
    @param opts carries output channel
    @param tagn specifies the current gedcom tag level (0, 1, ...)
    @param s specifies text to print to the output channel (already
    encode with gedcom charset)
    @param len specifies the number of characters (char or wide char)
    already printed
    @param i specifies the last char index (index to s -- one byte
    char) *)

let rec display_note_aux opts tagn s len i =
  let j = ref i in
  (* read wide char (case charset UTF-8) or char (other charset) in s string*)
  if !j = String.length s then Printf.ksprintf (oc opts) "\n"
  else
    (* \n, <br>, <br \> : cut text for CONTinuate with new gedcom line *)
    let br = find_br s i in
    if
      i <= String.length s - String.length br
      && String.lowercase_ascii (String.sub s i (String.length br)) = br
    then (
      Printf.ksprintf (oc opts) "\n%d CONT " (succ tagn);
      let i = i + String.length br in
      let i = if i < String.length s && s.[i] = '\n' then i + 1 else i in
      display_note_aux opts tagn s
        (String.length (string_of_int (succ tagn) ^ " CONT "))
        i)
    else if s.[i] = '\n' then (
      Printf.ksprintf (oc opts) "\n%d CONT " (succ tagn);
      let i = if i < String.length s then i + 1 else i in
      display_note_aux opts tagn s
        (String.length (string_of_int (succ tagn) ^ " CONT "))
        i)
    else if
      (* cut text at max length for CONCat with next gedcom line *)
      len = max_len
    then (
      Printf.ksprintf (oc opts) "\n%d CONC " (succ tagn);
      display_note_aux opts tagn s
        (String.length (string_of_int (succ tagn) ^ " CONC "))
        i)
    else
      (* continue same gedcom line *)

      (* FIXME: Rewrite this so we can get rid of this custom [nbc] *)
      let nbc c =
        if Char.code c < 0b10000000 then 1
        else if Char.code c < 0b11000000 then -1
        else if Char.code c < 0b11100000 then 2
        else if Char.code c < 0b11110000 then 3
        else if Char.code c < 0b11111000 then 4
        else if Char.code c < 0b11111100 then 5
        else if Char.code c < 0b11111110 then 6
        else -1
      in
      (* FIXME: avoid this buffer *)
      let b = Buffer.create 4 in
      let rec output_onechar () =
        if !j = String.length s then decr j (* non wide char / UTF-8 char *)
        else if opts.Gwexport.charset <> Gwexport.Utf8 then
          Buffer.add_char b s.[i] (* 1 to 4 bytes UTF-8 wide char *)
        else if i = !j || nbc s.[!j] = -1 then (
          Buffer.add_char b s.[!j];
          incr j;
          output_onechar ())
        else decr j
      in
      output_onechar ();
      (oc opts) (Buffer.contents b);
      display_note_aux opts tagn s (len + 1) (!j + 1)

let display_note opts tagn s =
  let tag = Printf.sprintf "%d NOTE " tagn in
  Printf.ksprintf (oc opts) "%s" tag;
  display_note_aux opts tagn (encode opts s) (String.length tag) 0

let ged_header opts base ifile ofile =
  Printf.ksprintf (oc opts) "0 HEAD\n";
  Printf.ksprintf (oc opts) "1 SOUR GeneWeb\n";
  Printf.ksprintf (oc opts) "2 VERS %s\n" Version.ver;
  Printf.ksprintf (oc opts) "2 NAME %s\n" (Filename.basename Sys.argv.(0));
  Printf.ksprintf (oc opts) "2 CORP INRIA\n";
  Printf.ksprintf (oc opts) "3 ADDR http://www.geneweb.org\n";
  Printf.ksprintf (oc opts) "2 DATA %s\n"
    (let fname = Filename.basename ifile in
     if Filename.check_suffix fname ".gwb" then fname else fname ^ ".gwb");
  (try
     let tm = Unix.localtime (Unix.time ()) in
     let mon = ged_month Dgregorian (tm.Unix.tm_mon + 1) in
     Printf.ksprintf (oc opts) "1 DATE %02d %s %d\n" tm.Unix.tm_mday mon
       (1900 + tm.Unix.tm_year);
     Printf.ksprintf (oc opts) "2 TIME %02d:%02d:%02d\n" tm.Unix.tm_hour
       tm.Unix.tm_min tm.Unix.tm_sec
   with _ -> ());
  if ofile <> "" then
    Printf.ksprintf (oc opts) "1 FILE %s\n" (Filename.basename ofile);
  Printf.ksprintf (oc opts) "1 GEDC\n";
  (match opts.Gwexport.charset with
  | Gwexport.Ansel | Gwexport.Ansi | Gwexport.Ascii ->
      Printf.ksprintf (oc opts) "2 VERS 5.5\n"
  | Gwexport.Utf8 -> Printf.ksprintf (oc opts) "2 VERS 5.5.1\n");
  Printf.ksprintf (oc opts) "2 FORM LINEAGE-LINKED\n";
  (match opts.Gwexport.charset with
  | Gwexport.Ansel -> Printf.ksprintf (oc opts) "1 CHAR ANSEL\n"
  | Gwexport.Ansi -> Printf.ksprintf (oc opts) "1 CHAR ANSI\n"
  | Gwexport.Ascii -> Printf.ksprintf (oc opts) "1 CHAR ASCII\n"
  | Gwexport.Utf8 -> Printf.ksprintf (oc opts) "1 CHAR UTF-8\n");
  if opts.Gwexport.no_notes = `none then
    match base_notes_read base "" with "" -> () | s -> display_note opts 1 s

let sub_string_index s t =
  let rec loop i j =
    if j = String.length t then Some (i - j)
    else if i = String.length s then None
    else if s.[i] = t.[j] then loop (i + 1) (j + 1)
    else loop (i + 1) 0
  in
  loop 0 0

let ged_1st_name base p =
  let fn = sou base (get_first_name p) in
  match get_first_names_aliases p with
  | n :: _ -> (
      let fna = sou base n in
      match sub_string_index fna fn with
      | Some i ->
          let j = i + String.length fn in
          String.sub fna 0 i ^ "\"" ^ fn ^ "\""
          ^ String.sub fna j (String.length fna - j)
      | None -> fn)
  | [] -> fn

let string_of_list =
  let rec loop r = function
    | s :: l -> if r = "" then loop s l else loop (r ^ "," ^ s) l
    | [] -> r
  in
  loop ""

let ged_index opts per =
  Printf.ksprintf (oc opts) "1 _GWID %s\n" (Gwdb.string_of_iper (get_iper per))

let ged_name opts base per =
  Printf.ksprintf (oc opts) "1 NAME %s /%s/\n"
    (encode opts (Mutil.nominative (ged_1st_name base per)))
    (encode opts (Mutil.nominative (sou base (get_surname per))));
  let n = sou base (get_public_name per) in
  if n <> "" then Printf.ksprintf (oc opts) "2 GIVN %s\n" (encode opts n);
  (match get_qualifiers per with
  | nn :: _ ->
      Printf.ksprintf (oc opts) "2 NICK %s\n" (encode opts (sou base nn))
  | [] -> ());
  (match get_surnames_aliases per with
  | [] -> ()
  | list ->
      let list = List.map (fun n -> encode opts (sou base n)) list in
      Printf.ksprintf (oc opts) "2 SURN %s\n" (string_of_list list));
  List.iter
    (fun s ->
      Printf.ksprintf (oc opts) "1 NAME %s\n" (encode opts (sou base s)))
    (get_aliases per)

let ged_sex opts per =
  match get_sex per with
  | Male -> Printf.ksprintf (oc opts) "1 SEX M\n"
  | Female -> Printf.ksprintf (oc opts) "1 SEX F\n"
  | Neuter -> ()

let ged_calendar opts = function
  | Dgregorian -> ()
  | Djulian -> Printf.ksprintf (oc opts) "@#DJULIAN@ "
  | Dfrench -> Printf.ksprintf (oc opts) "@#DFRENCH R@ "
  | Dhebrew -> Printf.ksprintf (oc opts) "@#DHEBREW@ "

let ged_date_dmy opts dt cal =
  (match dt.prec with
  | Sure -> ()
  | About -> Printf.ksprintf (oc opts) "ABT "
  | Maybe -> Printf.ksprintf (oc opts) "EST "
  | Before -> Printf.ksprintf (oc opts) "BEF "
  | After -> Printf.ksprintf (oc opts) "AFT "
  | OrYear _ -> Printf.ksprintf (oc opts) "BET "
  | YearInt _ -> Printf.ksprintf (oc opts) "BET ");
  ged_calendar opts cal;
  if dt.day <> 0 then Printf.ksprintf (oc opts) "%02d " dt.day;
  if dt.month <> 0 then Printf.ksprintf (oc opts) "%s " (ged_month cal dt.month);
  Printf.ksprintf (oc opts) "%d" dt.year;
  match dt.prec with
  | OrYear dmy2 ->
      Printf.ksprintf (oc opts) " AND ";
      ged_calendar opts cal;
      if dmy2.day2 <> 0 then Printf.ksprintf (oc opts) "%02d " dmy2.day2;
      if dmy2.month2 <> 0 then
        Printf.ksprintf (oc opts) "%s " (ged_month cal dmy2.month2);
      Printf.ksprintf (oc opts) "%d" dmy2.year2
  | YearInt dmy2 ->
      Printf.ksprintf (oc opts) " AND ";
      ged_calendar opts cal;
      if dmy2.day2 <> 0 then Printf.ksprintf (oc opts) "%02d " dmy2.day2;
      if dmy2.month2 <> 0 then
        Printf.ksprintf (oc opts) "%s " (ged_month cal dmy2.month2);
      Printf.ksprintf (oc opts) "%d" dmy2.year2
  | _ -> ()

let ged_date opts = function
  | Dgreg (d, Dgregorian) -> ged_date_dmy opts d Dgregorian
  | Dgreg (d, Djulian) ->
      ged_date_dmy opts (Calendar.julian_of_gregorian d) Djulian
  | Dgreg (d, Dfrench) ->
      ged_date_dmy opts (Calendar.french_of_gregorian d) Dfrench
  | Dgreg (d, Dhebrew) ->
      ged_date_dmy opts (Calendar.hebrew_of_gregorian d) Dhebrew
  | Dtext t -> Printf.ksprintf (oc opts) "(%s)" t

let print_sour opts n s = Printf.ksprintf (oc opts) "%d SOUR %s\n" n s

let ged_ev_detail opts n typ d pl note src =
  (match (typ, d, pl, note, src) with
  | "", None, "", "", "" -> Printf.ksprintf (oc opts) " Y"
  | _ -> ());
  Printf.ksprintf (oc opts) "\n";
  if typ = "" then () else Printf.ksprintf (oc opts) "%d TYPE %s\n" n typ;
  (match d with
  | Some d ->
      Printf.ksprintf (oc opts) "%d DATE " n;
      ged_date opts d;
      Printf.ksprintf (oc opts) "\n"
  | None -> ());
  if pl <> "" then Printf.ksprintf (oc opts) "%d PLAC %s\n" n (encode opts pl);
  if opts.Gwexport.no_notes <> `nnn && note <> "" then display_note opts n note;
  if opts.Gwexport.source = None && src <> "" then
    print_sour opts n (encode opts src)

let ged_tag_pevent base evt =
  match evt.epers_name with
  | Epers_Birth -> "BIRT"
  | Epers_Baptism -> "BAPM"
  | Epers_Death -> "DEAT"
  | Epers_Burial -> "BURI"
  | Epers_Cremation -> "CREM"
  | Epers_Accomplishment -> "Accomplishment"
  | Epers_Acquisition -> "Acquisition"
  | Epers_Adhesion -> "Membership"
  | Epers_BaptismLDS -> "BAPL"
  | Epers_BarMitzvah -> "BARM"
  | Epers_BatMitzvah -> "BASM"
  | Epers_Benediction -> "BLES"
  | Epers_ChangeName -> "Change name"
  | Epers_Circumcision -> "Circumcision"
  | Epers_Confirmation -> "CONF"
  | Epers_ConfirmationLDS -> "CONL"
  | Epers_Decoration -> "Award"
  | Epers_DemobilisationMilitaire -> "Military discharge"
  | Epers_Diploma -> "Degree"
  | Epers_Distinction -> "Distinction"
  | Epers_Dotation -> "ENDL"
  | Epers_DotationLDS -> "DotationLDS"
  | Epers_Education -> "EDUC"
  | Epers_Election -> "Election"
  | Epers_Emigration -> "EMIG"
  | Epers_Excommunication -> "Excommunication"
  | Epers_FamilyLinkLDS -> "Family link LDS"
  | Epers_FirstCommunion -> "FCOM"
  | Epers_Funeral -> "Funeral"
  | Epers_Graduate -> "GRAD"
  | Epers_Hospitalisation -> "Hospitalization"
  | Epers_Illness -> "Illness"
  | Epers_Immigration -> "IMMI"
  | Epers_ListePassenger -> "Passenger list"
  | Epers_MilitaryDistinction -> "Military distinction"
  | Epers_MilitaryPromotion -> "Military promotion"
  | Epers_MilitaryService -> "Military service"
  | Epers_MobilisationMilitaire -> "Military mobilization"
  | Epers_Naturalisation -> "NATU"
  | Epers_Occupation -> "OCCU"
  | Epers_Ordination -> "ORDN"
  | Epers_Property -> "PROP"
  | Epers_Recensement -> "CENS"
  | Epers_Residence -> "RESI"
  | Epers_Retired -> "RETI"
  | Epers_ScellentChildLDS -> "SLGC"
  | Epers_ScellentParentLDS -> "Scellent parent LDS"
  | Epers_ScellentSpouseLDS -> "SLGS"
  | Epers_VenteBien -> "Property sale"
  | Epers_Will -> "WILL"
  | Epers_Name n -> sou base n

let is_primary_pevents = function
  | Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial | Epers_Cremation
  | Epers_BaptismLDS | Epers_BarMitzvah | Epers_BatMitzvah | Epers_Benediction
  | Epers_Confirmation | Epers_ConfirmationLDS | Epers_Dotation
  | Epers_Education | Epers_Emigration | Epers_FirstCommunion | Epers_Graduate
  | Epers_Immigration | Epers_Naturalisation | Epers_Occupation
  | Epers_Ordination | Epers_Property | Epers_Recensement | Epers_Residence
  | Epers_Retired | Epers_ScellentChildLDS | Epers_ScellentSpouseLDS
  | Epers_Will ->
      true
  | _ -> false

let relation_format_of_witness_kind :
    witness_kind -> ('a, unit, string, unit) format4 = function
  | Witness -> "3 RELA Witness"
  | Witness_GodParent -> "3 RELA GODP"
  | Witness_CivilOfficer -> "3 RELA Civil officer"
  | Witness_ReligiousOfficer -> "3 RELA Religious officer"
  | Witness_Informant -> "3 RELA Informant"
  | Witness_Attending -> "3 RELA Attending"
  | Witness_Mentioned -> "3 RELA Mentioned"
  | Witness_Other -> "3 RELA Other"

let oc' opts s = Printf.ksprintf (oc opts) (s ^^ "\n")
let oc_witness_kind opts wk = oc' opts (relation_format_of_witness_kind wk)

let ged_pevent opts base per_sel evt =
  let typ =
    if is_primary_pevents evt.epers_name then (
      let tag = ged_tag_pevent base evt in
      Printf.ksprintf (oc opts) "1 %s" tag;
      "")
    else (
      Printf.ksprintf (oc opts) "1 EVEN";
      ged_tag_pevent base evt)
  in
  let date = Date.od_of_cdate evt.epers_date in
  let place = sou base evt.epers_place in
  let note = sou base evt.epers_note in
  let src = sou base evt.epers_src in
  ged_ev_detail opts 2 typ date place note src;
  Array.iter
    (fun (ip, wk) ->
      if per_sel ip then (
        Printf.ksprintf (oc opts) "2 ASSO @I%d@\n" (int_of_iper ip + 1);
        Printf.ksprintf (oc opts) "3 TYPE INDI\n";
        oc_witness_kind opts wk))
    evt.epers_witnesses

let adop_fam_list = ref []

let ged_fam_adop opts i (fath, moth, _) =
  Printf.ksprintf (oc opts) "0 @F%d@ FAM\n" i;
  (match fath with
  | Some i -> Printf.ksprintf (oc opts) "1 HUSB @I%d@\n" (int_of_iper i + 1)
  | _ -> ());
  match moth with
  | Some i -> Printf.ksprintf (oc opts) "1 WIFE @I%d@\n" (int_of_iper i + 1)
  | _ -> ()

let ged_ind_ev_str opts base per per_sel =
  List.iter (ged_pevent opts base per_sel) (get_pevents per)

let ged_title opts base per tit =
  Printf.ksprintf (oc opts) "1 TITL ";
  Printf.ksprintf (oc opts) "%s" (encode opts (sou base tit.t_ident));
  (match sou base tit.t_place with
  | "" -> ()
  | pl -> Printf.ksprintf (oc opts) ", %s" (encode opts pl));
  if tit.t_nth <> 0 then Printf.ksprintf (oc opts) ", %d" tit.t_nth;
  Printf.ksprintf (oc opts) "\n";
  (match
     (Date.od_of_cdate tit.t_date_start, Date.od_of_cdate tit.t_date_end)
   with
  | None, None -> ()
  | Some sd, None ->
      Printf.ksprintf (oc opts) "2 DATE FROM ";
      ged_date opts sd;
      Printf.ksprintf (oc opts) "\n"
  | None, Some sd ->
      Printf.ksprintf (oc opts) "2 DATE TO ";
      ged_date opts sd;
      Printf.ksprintf (oc opts) "\n"
  | Some sd1, Some sd2 ->
      Printf.ksprintf (oc opts) "2 DATE FROM ";
      ged_date opts sd1;
      Printf.ksprintf (oc opts) " TO ";
      ged_date opts sd2;
      Printf.ksprintf (oc opts) "\n");
  match tit.t_name with
  | Tmain ->
      Printf.ksprintf (oc opts) "2 NOTE %s\n"
        (encode opts (sou base (get_public_name per)))
  | Tname n ->
      Printf.ksprintf (oc opts) "2 NOTE %s\n" (encode opts (sou base n))
  | Tnone -> ()

let ged_ind_attr_str opts base per =
  (match sou base (get_occupation per) with
  | "" -> ()
  | occu -> Printf.ksprintf (oc opts) "1 OCCU %s\n" (encode opts occu));
  List.iter (ged_title opts base per) (get_titles per)

let ged_famc opts fam_sel asc =
  match get_parents asc with
  | Some ifam ->
      if fam_sel ifam then
        Printf.ksprintf (oc opts) "1 FAMC @F%d@\n" (int_of_ifam ifam + 1)
  | None -> ()

let ged_fams opts fam_sel ifam =
  if fam_sel ifam then
    Printf.ksprintf (oc opts) "1 FAMS @F%d@\n" (int_of_ifam ifam + 1)

let ged_godparent opts per_sel godp = function
  | Some ip ->
      if per_sel ip then (
        Printf.ksprintf (oc opts) "1 ASSO @I%d@\n" (int_of_iper ip + 1);
        Printf.ksprintf (oc opts) "2 TYPE INDI\n";
        Printf.ksprintf (oc opts) "2 RELA %s\n" godp)
  | None -> ()

let ged_witness opts fam_sel ifam =
  if fam_sel ifam then (
    Printf.ksprintf (oc opts) "1 ASSO @F%d@\n" (int_of_ifam ifam + 1);
    Printf.ksprintf (oc opts) "2 TYPE FAM\n";
    Printf.ksprintf (oc opts) "2 RELA witness\n")

let ged_asso opts base (per_sel, fam_sel) per =
  List.iter
    (fun r ->
      if r.r_type = GodParent then (
        ged_godparent opts per_sel "GODF" r.r_fath;
        ged_godparent opts per_sel "GODM" r.r_moth))
    (get_rparents per);
  List.iter
    (fun ic ->
      let c = poi base ic in
      if get_sex c = Male then
        List.iter
          (fun ifam ->
            let fam = foi base ifam in
            if Array.mem (get_iper per) (get_witnesses fam) then
              ged_witness opts fam_sel ifam)
          (Array.to_list (get_family c)))
    (get_related per)

let ged_psource opts base per =
  match opts.Gwexport.source with
  | Some "" -> ()
  | Some s -> print_sour opts 1 (encode opts s)
  | None -> (
      match sou base (get_psources per) with
      | "" -> ()
      | s -> print_sour opts 1 (encode opts s))

let has_image_file opts base p =
  let s = Image.default_portrait_filename base p in
  let f = Filename.concat opts.Gwexport.img_base_path s in
  if Sys.file_exists (f ^ ".gif") then Some (f ^ ".gif")
  else if Sys.file_exists (f ^ ".jpg") then Some (f ^ ".jpg")
  else if Sys.file_exists (f ^ ".png") then Some (f ^ ".png")
  else None

let ged_multimedia_link opts base per =
  match sou base (get_image per) with
  | "" -> (
      if (not opts.Gwexport.no_picture) && opts.Gwexport.picture_path then
        match has_image_file opts base per with
        | Some s ->
            Printf.ksprintf (oc opts) "1 OBJE\n";
            Printf.ksprintf (oc opts) "2 FILE %s\n" s
        | None -> ())
  | s ->
      if not opts.Gwexport.no_picture then (
        Printf.ksprintf (oc opts) "1 OBJE\n";
        Printf.ksprintf (oc opts) "2 FILE %s\n" s)

let ged_note opts base per =
  if opts.Gwexport.no_notes <> `nnn then
    match sou base (get_notes per) with "" -> () | s -> display_note opts 1 s

let ged_tag_fevent base evt =
  match evt.efam_name with
  | Efam_Marriage -> "MARR"
  | Efam_NoMarriage -> "unmarried"
  | Efam_NoMention -> "nomen"
  | Efam_Engage -> "ENGA"
  | Efam_Divorce -> "DIV"
  | Efam_Separated -> "SEP"
  | Efam_Annulation -> "ANUL"
  | Efam_MarriageBann -> "MARB"
  | Efam_MarriageContract -> "MARC"
  | Efam_MarriageLicense -> "MARL"
  | Efam_PACS -> "pacs"
  | Efam_Residence -> "residence"
  | Efam_Name n -> sou base n

let is_primary_fevents = function
  | Efam_Marriage | Efam_Engage | Efam_Divorce | Efam_Separated
  | Efam_Annulation | Efam_MarriageBann | Efam_MarriageContract
  | Efam_MarriageLicense ->
      true
  | _ -> false

let ged_fevent opts base per_sel evt =
  let typ =
    if is_primary_fevents evt.efam_name then (
      let tag = ged_tag_fevent base evt in
      Printf.ksprintf (oc opts) "1 %s" tag;
      "")
    else (
      Printf.ksprintf (oc opts) "1 EVEN";
      ged_tag_fevent base evt)
  in
  let date = Date.od_of_cdate evt.efam_date in
  let place = sou base evt.efam_place in
  let note = sou base evt.efam_note in
  let src = sou base evt.efam_src in
  ged_ev_detail opts 2 typ date place note src;
  Array.iter
    (fun (ip, wk) ->
      if per_sel ip then (
        Printf.ksprintf (oc opts) "2 ASSO @I%d@\n" (int_of_iper ip + 1);
        Printf.ksprintf (oc opts) "3 TYPE INDI\n";
        oc_witness_kind opts wk))
    evt.efam_witnesses

let ged_child opts per_sel chil =
  if per_sel chil then
    Printf.ksprintf (oc opts) "1 CHIL @I%d@\n" (int_of_iper chil + 1)

let ged_fsource opts base fam =
  match opts.Gwexport.source with
  | Some "" -> ()
  | Some s -> print_sour opts 1 (encode opts s)
  | None -> (
      match sou base (get_fsources fam) with
      | "" -> ()
      | s -> print_sour opts 1 (encode opts s))

let ged_comment opts base fam =
  if opts.Gwexport.no_notes <> `nnn then
    match sou base (get_comment fam) with
    | "" -> ()
    | s -> display_note opts 1 s

let has_personal_infos base per =
  get_parents per <> None
  || sou base (get_first_name per) <> "?"
  || sou base (get_surname per) <> "?"
  || get_birth per <> Date.cdate_None
  || sou base (get_birth_place per) <> ""
  || (get_death per <> NotDead && get_death per <> DontKnowIfDead)
  || sou base (get_occupation per) <> ""
  || get_titles per <> []

let ged_ind_record with_indexes opts base ((per_sel, fam_sel) as sel) i =
  let per = poi base i in
  if has_personal_infos base per then (
    Printf.ksprintf (oc opts) "0 @I%d@ INDI\n" (int_of_iper i + 1);
    ged_name opts base per;
    if with_indexes then ged_index opts per;
    ged_sex opts per;
    ged_ind_ev_str opts base per per_sel;
    ged_ind_attr_str opts base per;
    ged_famc opts fam_sel per;
    Array.iter (ged_fams opts fam_sel) (get_family per);
    ged_asso opts base sel per;
    ged_psource opts base per;
    ged_multimedia_link opts base per;
    ged_note opts base per)

let ged_fam_record opts base (per_sel, _fam_sel) ifam =
  let fam = foi base ifam in
  Printf.ksprintf (oc opts) "0 @F%d@ FAM\n" (int_of_ifam ifam + 1);
  List.iter (ged_fevent opts base per_sel) (get_fevents fam);
  if
    per_sel (get_father fam)
    && has_personal_infos base (poi base (get_father fam))
  then
    Printf.ksprintf (oc opts) "1 HUSB @I%d@\n" (int_of_iper (get_father fam) + 1);
  if
    per_sel (get_mother fam)
    && has_personal_infos base (poi base (get_mother fam))
  then
    Printf.ksprintf (oc opts) "1 WIFE @I%d@\n" (int_of_iper (get_mother fam) + 1);
  Array.iter (ged_child opts per_sel) (get_children fam);
  ged_fsource opts base fam;
  ged_comment opts base fam

let gwb2ged with_indexes opts ((per_sel, fam_sel) as sel) =
  match opts.Gwexport.base with
  | Some (ifile, base) ->
      let ofile, oc, close = opts.Gwexport.oc in
      if not opts.Gwexport.mem then (
        load_ascends_array base;
        load_unions_array base;
        load_couples_array base;
        load_descends_array base);
      ged_header opts base ifile ofile;
      Gwdb.Collection.iter
        (fun i -> if per_sel i then ged_ind_record with_indexes opts base sel i)
        (Gwdb.ipers base);
      Gwdb.Collection.iter
        (fun i -> if fam_sel i then ged_fam_record opts base sel i)
        (Gwdb.ifams base);
      let _ =
        List.fold_right
          (fun adop i ->
            ged_fam_adop opts i adop;
            i + 1)
          !adop_fam_list
          (nb_of_families base + 1)
      in
      Printf.ksprintf oc "0 TRLR\n";
      close ()
  | None -> assert false