1753 lines
61 KiB
OCaml
1753 lines
61 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Geneweb
|
|
open Def
|
|
open Gwdb
|
|
open Gwexport
|
|
|
|
let old_gw = ref false
|
|
let only_file = ref ""
|
|
let out_dir = ref ""
|
|
let raw_output = ref false
|
|
let sep_limit = ref 21
|
|
let separate_list = ref []
|
|
|
|
(* Returns true if `old_gw` is `true` and there exist an event associated to a
|
|
person that:
|
|
* is either a birth, baptism, death, burial or a cremation and is associated to
|
|
a note or a witness;
|
|
* is any other event.
|
|
Otherwise, returns false *)
|
|
let put_events_in_notes base p =
|
|
(* Si on est en mode old_gw, on mets tous les évènements *)
|
|
(* dans les notes. *)
|
|
if !old_gw then
|
|
let rec loop pevents =
|
|
match pevents with
|
|
| [] -> false
|
|
| evt :: events -> (
|
|
match evt.epers_name with
|
|
| Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial
|
|
| Epers_Cremation ->
|
|
if sou base evt.epers_note <> "" || evt.epers_witnesses <> [||]
|
|
then true
|
|
else loop events
|
|
| _ -> true)
|
|
in
|
|
loop (get_pevents p)
|
|
else false
|
|
|
|
let (ht_dup_occ : (Gwdb.iper, int) Hashtbl.t) = Hashtbl.create 20001
|
|
let (ht_orig_occ : (string, int list) Hashtbl.t) = Hashtbl.create 20001
|
|
|
|
let prepare_free_occ ?(select = fun _ -> true) base =
|
|
(* Parce qu'on est obligé ... *)
|
|
let sn = "?" in
|
|
let fn = "?" in
|
|
let key = Name.lower fn ^ " #@# " ^ Name.lower sn in
|
|
Hashtbl.add ht_orig_occ key [ 0 ];
|
|
Gwdb.Collection.iter
|
|
(fun ip ->
|
|
if select ip then
|
|
let p = poi base ip in
|
|
let sn = sou base (get_surname p) in
|
|
let fn = sou base (get_first_name p) in
|
|
if sn = "?" && fn = "?" then ()
|
|
else
|
|
let fn = Name.lower fn in
|
|
let sn = Name.lower sn in
|
|
if fn = "" || sn = "" then
|
|
let key = fn ^ " #@# " ^ sn in
|
|
let occ = get_occ p in
|
|
try
|
|
let l = Hashtbl.find ht_orig_occ key in
|
|
if List.mem occ l then Hashtbl.add ht_dup_occ ip occ
|
|
else Hashtbl.replace ht_orig_occ key (occ :: l)
|
|
with Not_found -> Hashtbl.add ht_orig_occ key [ occ ])
|
|
(Gwdb.ipers base);
|
|
Hashtbl.iter
|
|
(fun key l -> Hashtbl.replace ht_orig_occ key (List.sort compare l))
|
|
ht_orig_occ;
|
|
Hashtbl.iter
|
|
(fun ip _ ->
|
|
let p = poi base ip in
|
|
let sn = sou base (get_surname p) in
|
|
let fn = sou base (get_first_name p) in
|
|
let key = Name.lower fn ^ " #@# " ^ Name.lower sn in
|
|
try
|
|
let list_occ = Hashtbl.find ht_orig_occ key in
|
|
let rec loop list init new_list =
|
|
match list with
|
|
| x :: y :: l when y - x > 1 ->
|
|
(succ x, List.rev_append (y :: succ x :: x :: new_list) l)
|
|
| x :: l -> loop l (succ x) (x :: new_list)
|
|
| [] -> (init, [ init ])
|
|
in
|
|
let new_occ, new_list_occ = loop list_occ 0 [] in
|
|
Hashtbl.replace ht_dup_occ ip new_occ;
|
|
Hashtbl.replace ht_orig_occ key new_list_occ
|
|
with Not_found -> ())
|
|
ht_dup_occ
|
|
|
|
let get_new_occ p =
|
|
try Hashtbl.find ht_dup_occ (get_iper p) with Not_found -> get_occ p
|
|
|
|
type mfam = {
|
|
m_ifam : ifam;
|
|
m_fam : family;
|
|
m_fath : person;
|
|
m_moth : person;
|
|
m_chil : person array;
|
|
}
|
|
|
|
let soy y = if y = 0 then "-0" else string_of_int y
|
|
let oc opts = match opts.Gwexport.oc with _, oc, _ -> oc
|
|
|
|
let print_date_dmy opts d =
|
|
(match d.prec with
|
|
| About -> Printf.ksprintf (oc opts) "~"
|
|
| Maybe -> Printf.ksprintf (oc opts) "?"
|
|
| Before -> Printf.ksprintf (oc opts) "<"
|
|
| After -> Printf.ksprintf (oc opts) ">"
|
|
| Sure | OrYear _ | YearInt _ -> ());
|
|
if d.month = 0 then Printf.ksprintf (oc opts) "%s" (soy d.year)
|
|
else if d.day = 0 then Printf.ksprintf (oc opts) "%d/%s" d.month (soy d.year)
|
|
else Printf.ksprintf (oc opts) "%d/%d/%s" d.day d.month (soy d.year);
|
|
match d.prec with
|
|
| OrYear d2 ->
|
|
if not !old_gw then
|
|
if d2.month2 = 0 then Printf.ksprintf (oc opts) "|%s" (soy d2.year2)
|
|
else if d2.day2 = 0 then
|
|
Printf.ksprintf (oc opts) "|%d/%s" d2.month2 (soy d2.year2)
|
|
else
|
|
Printf.ksprintf (oc opts) "|%d/%d/%s" d2.day2 d2.month2 (soy d2.year2)
|
|
else Printf.ksprintf (oc opts) "|%s" (soy d2.year2)
|
|
| YearInt d2 ->
|
|
if not !old_gw then
|
|
if d2.month2 = 0 then Printf.ksprintf (oc opts) "..%s" (soy d2.year2)
|
|
else if d2.day2 = 0 then
|
|
Printf.ksprintf (oc opts) "..%d/%s" d2.month2 (soy d2.year2)
|
|
else
|
|
Printf.ksprintf (oc opts) "..%d/%d/%s" d2.day2 d2.month2
|
|
(soy d2.year2)
|
|
else Printf.ksprintf (oc opts) "..%s" (soy d2.year2)
|
|
| _ -> ()
|
|
|
|
let is_printable = function '\000' .. '\031' -> false | _ -> true
|
|
|
|
let starting_char no_num s =
|
|
match s.[0] with
|
|
(*'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' *)
|
|
| 'a' .. 'z' | 'A' .. 'Z' | '\xE0' .. '\xFD' | '\xC0' .. '\xDD' -> true
|
|
| '0' .. '9' -> not no_num
|
|
| '?' -> if s = "?" then true else false
|
|
| _ -> false
|
|
|
|
let no_newlines s =
|
|
let conv_char i = match s.[i] with '\n' | '\r' -> ' ' | _ -> s.[i] in
|
|
String.init (String.length s) conv_char
|
|
|
|
let gen_correct_string no_num no_colon s =
|
|
let s = String.trim s in
|
|
let rec loop i len =
|
|
if i = String.length s then Buff.get len
|
|
else if len = 0 && not (starting_char no_num s) then
|
|
loop i (Buff.store len '_')
|
|
else
|
|
match s.[i] with
|
|
| ' ' | '\n' | '\t' ->
|
|
if i = String.length s - 1 then Buff.get len
|
|
else loop (i + 1) (Buff.store len '_')
|
|
| '_' | '\\' -> loop (i + 1) (Buff.store (Buff.store len '\\') s.[i])
|
|
| ':' when no_colon ->
|
|
let len = Buff.store len '\\' in
|
|
loop (i + 1) (Buff.store (Buff.store len '\\') s.[i])
|
|
| c ->
|
|
let c = if is_printable c then c else '_' in
|
|
loop (i + 1) (Buff.store len c)
|
|
in
|
|
loop 0 0
|
|
|
|
let s_correct_string s =
|
|
let s = gen_correct_string false false s in
|
|
if s = "" then "_" else s
|
|
|
|
let s_correct_string_nonum s =
|
|
let s = gen_correct_string true false s in
|
|
if s = "" then "_" else s
|
|
|
|
let correct_string base is = s_correct_string (sou base is)
|
|
|
|
let correct_string_no_colon base is =
|
|
gen_correct_string false true (sou base is)
|
|
|
|
let gen_print_date opts no_colon = function
|
|
| Dgreg (d, Dgregorian) -> print_date_dmy opts d
|
|
| Dgreg (d, Djulian) ->
|
|
print_date_dmy opts (Calendar.julian_of_gregorian d);
|
|
Printf.ksprintf (oc opts) "J"
|
|
| Dgreg (d, Dfrench) ->
|
|
print_date_dmy opts (Calendar.french_of_gregorian d);
|
|
Printf.ksprintf (oc opts) "F"
|
|
| Dgreg (d, Dhebrew) ->
|
|
print_date_dmy opts (Calendar.hebrew_of_gregorian d);
|
|
Printf.ksprintf (oc opts) "H"
|
|
| Dtext t ->
|
|
(* Dans le cas d'une date texte pour un titre, on échappe les ':' *)
|
|
let t = gen_correct_string false no_colon t in
|
|
Printf.ksprintf (oc opts) "0(%s)" t
|
|
|
|
let gen_print_date_option opts no_colon = function
|
|
| Some d -> gen_print_date opts no_colon d
|
|
| None -> ()
|
|
|
|
let print_date opts = gen_print_date opts false
|
|
let print_date_option opts = gen_print_date_option opts false
|
|
let print_title_date_option opts = gen_print_date_option opts true
|
|
|
|
let lines_list_of_string s =
|
|
let rec loop lines len i =
|
|
if i = String.length s then
|
|
List.rev (if len = 0 then lines else Buff.get len :: lines)
|
|
else if s.[i] = '\n' then
|
|
let line = Buff.get len in
|
|
loop (line :: lines) 0 (i + 1)
|
|
else loop lines (Buff.store len s.[i]) (i + 1)
|
|
in
|
|
loop [] 0 0
|
|
|
|
let has_infos_not_dates opts base p =
|
|
let has_picture_to_export =
|
|
sou base (get_image p) <> "" && not opts.no_picture
|
|
in
|
|
get_first_names_aliases p <> []
|
|
|| get_surnames_aliases p <> []
|
|
|| sou base (get_public_name p) <> ""
|
|
|| has_picture_to_export
|
|
|| get_qualifiers p <> []
|
|
|| get_aliases p <> []
|
|
|| get_titles p <> []
|
|
|| get_access p <> IfTitles
|
|
|| sou base (get_occupation p) <> ""
|
|
|| (opts.source <> None || sou base @@ get_psources p <> "")
|
|
|| sou base (get_birth_place p) <> ""
|
|
|| (opts.source = None && sou base (get_birth_src p) <> "")
|
|
|| sou base (get_baptism_place p) <> ""
|
|
|| (opts.source = None && sou base (get_baptism_src p) <> "")
|
|
|| sou base (get_death_place p) <> ""
|
|
|| (opts.source = None && sou base (get_death_src p) <> "")
|
|
|| sou base (get_burial_place p) <> ""
|
|
|| (opts.source = None && sou base (get_burial_src p) <> "")
|
|
|
|
let has_infos opts base p =
|
|
has_infos_not_dates opts base p
|
|
|| get_birth p <> Date.cdate_None
|
|
|| get_baptism p <> Date.cdate_None
|
|
|| get_death p <> NotDead
|
|
|
|
let print_if_not_equal_to opts x base lab is =
|
|
if sou base is <> x then
|
|
Printf.ksprintf (oc opts) " %s %s" lab (correct_string base is)
|
|
|
|
let print_src_if_not_equal_to opts x base lab is =
|
|
match opts.source with
|
|
| None -> if sou base is <> "" then print_if_not_equal_to opts x base lab is
|
|
| Some "" -> ()
|
|
| Some x -> Printf.ksprintf (oc opts) " %s %s" lab (s_correct_string x)
|
|
|
|
let print_if_no_empty opts = print_if_not_equal_to opts ""
|
|
|
|
let print_first_name_alias opts base is =
|
|
Printf.ksprintf (oc opts) " {%s}" (correct_string base is)
|
|
|
|
let print_surname_alias opts base is =
|
|
Printf.ksprintf (oc opts) " #salias %s" (correct_string base is)
|
|
|
|
let print_qualifier opts base is =
|
|
Printf.ksprintf (oc opts) " #nick %s" (correct_string base is)
|
|
|
|
let print_alias opts base is =
|
|
Printf.ksprintf (oc opts) " #alias %s" (correct_string base is)
|
|
|
|
let print_burial opts b =
|
|
match b with
|
|
| Buried cod -> (
|
|
Printf.ksprintf (oc opts) " #buri";
|
|
match Date.od_of_cdate cod with
|
|
| Some d ->
|
|
Printf.ksprintf (oc opts) " ";
|
|
print_date opts d;
|
|
()
|
|
| None -> ())
|
|
| Cremated cod -> (
|
|
Printf.ksprintf (oc opts) " #crem";
|
|
match Date.od_of_cdate cod with
|
|
| Some d ->
|
|
Printf.ksprintf (oc opts) " ";
|
|
print_date opts d;
|
|
()
|
|
| None -> ())
|
|
| UnknownBurial -> ()
|
|
|
|
let print_title opts base t =
|
|
let t_date_start = Date.od_of_cdate t.t_date_start in
|
|
let t_date_end = Date.od_of_cdate t.t_date_end in
|
|
Printf.ksprintf (oc opts) " [";
|
|
(match t.t_name with
|
|
| Tmain -> Printf.ksprintf (oc opts) "*"
|
|
| Tname s -> Printf.ksprintf (oc opts) "%s" (correct_string_no_colon base s)
|
|
| Tnone -> ());
|
|
Printf.ksprintf (oc opts) ":";
|
|
Printf.ksprintf (oc opts) "%s" (correct_string_no_colon base t.t_ident);
|
|
Printf.ksprintf (oc opts) ":";
|
|
Printf.ksprintf (oc opts) "%s" (correct_string_no_colon base t.t_place);
|
|
(if t.t_nth <> 0 then Printf.ksprintf (oc opts) ":"
|
|
else
|
|
match (t_date_start, t_date_end) with
|
|
| Some _, _ | _, Some _ -> Printf.ksprintf (oc opts) ":"
|
|
| _ -> ());
|
|
print_title_date_option opts t_date_start;
|
|
(if t.t_nth <> 0 then Printf.ksprintf (oc opts) ":"
|
|
else
|
|
match t_date_end with Some _ -> Printf.ksprintf (oc opts) ":" | None -> ());
|
|
print_title_date_option opts t_date_end;
|
|
if t.t_nth <> 0 then Printf.ksprintf (oc opts) ":%d" t.t_nth;
|
|
Printf.ksprintf (oc opts) "]"
|
|
|
|
let zero_birth_is_required opts base is_child p =
|
|
if get_baptism p <> Date.cdate_None then false
|
|
else
|
|
match get_death p with
|
|
| Death (_, _) | DeadYoung | DeadDontKnowWhen | OfCourseDead -> true
|
|
| DontKnowIfDead
|
|
when (not is_child)
|
|
&& (not (has_infos_not_dates opts base p))
|
|
&& p_first_name base p <> "?"
|
|
&& p_surname base p <> "?" ->
|
|
true
|
|
| _ -> false
|
|
|
|
let print_infos opts base is_child csrc cbp p =
|
|
List.iter (print_first_name_alias opts base) (get_first_names_aliases p);
|
|
List.iter (print_surname_alias opts base) (get_surnames_aliases p);
|
|
(match get_public_name p with
|
|
| s when sou base s <> "" ->
|
|
Printf.ksprintf (oc opts) " (%s)" (correct_string base s)
|
|
| _ -> ());
|
|
if not opts.no_picture then print_if_no_empty opts base "#image" (get_image p);
|
|
List.iter (print_qualifier opts base) (get_qualifiers p);
|
|
List.iter (print_alias opts base) (get_aliases p);
|
|
List.iter (print_title opts base) (get_titles p);
|
|
(match get_access p with
|
|
| IfTitles -> ()
|
|
| Public -> Printf.ksprintf (oc opts) " #apubl"
|
|
| Private -> Printf.ksprintf (oc opts) " #apriv");
|
|
print_if_no_empty opts base "#occu" (get_occupation p);
|
|
print_src_if_not_equal_to opts csrc base "#src" (get_psources p);
|
|
(match Date.od_of_cdate (get_birth p) with
|
|
| Some d ->
|
|
Printf.ksprintf (oc opts) " ";
|
|
print_date opts d
|
|
| _ when zero_birth_is_required opts base is_child p ->
|
|
Printf.ksprintf (oc opts) " 0"
|
|
| None -> ());
|
|
print_if_not_equal_to opts cbp base "#bp" (get_birth_place p);
|
|
if opts.source = None then print_if_no_empty opts base "#bs" (get_birth_src p);
|
|
(match Date.od_of_cdate (get_baptism p) with
|
|
| Some d ->
|
|
Printf.ksprintf (oc opts) " !";
|
|
print_date opts d
|
|
| None -> ());
|
|
print_if_no_empty opts base "#pp" (get_baptism_place p);
|
|
if opts.source = None then
|
|
print_if_no_empty opts base "#ps" (get_baptism_src p);
|
|
(match get_death p with
|
|
| Death (dr, d) ->
|
|
Printf.ksprintf (oc opts) " ";
|
|
(match dr with
|
|
| Killed -> Printf.ksprintf (oc opts) "k"
|
|
| Murdered -> Printf.ksprintf (oc opts) "m"
|
|
| Executed -> Printf.ksprintf (oc opts) "e"
|
|
| Disappeared -> Printf.ksprintf (oc opts) "s"
|
|
| _ -> ());
|
|
print_date opts (Date.date_of_cdate d)
|
|
| DeadYoung -> Printf.ksprintf (oc opts) " mj"
|
|
| DeadDontKnowWhen -> Printf.ksprintf (oc opts) " 0"
|
|
| DontKnowIfDead -> (
|
|
match
|
|
(Date.od_of_cdate (get_birth p), Date.od_of_cdate (get_baptism p))
|
|
with
|
|
| Some _, _ | _, Some _ -> Printf.ksprintf (oc opts) " ?"
|
|
| _ -> ())
|
|
| OfCourseDead -> Printf.ksprintf (oc opts) " od"
|
|
| NotDead -> ());
|
|
print_if_no_empty opts base "#dp" (get_death_place p);
|
|
if opts.source = None then print_if_no_empty opts base "#ds" (get_death_src p);
|
|
print_burial opts (get_burial p);
|
|
print_if_no_empty opts base "#rp" (get_burial_place p);
|
|
if opts.source = None then
|
|
print_if_no_empty opts base "#rs" (get_burial_src p)
|
|
|
|
type gen = {
|
|
mark : (iper, bool) Gwdb.Marker.t;
|
|
mark_rel : (iper, bool) Gwdb.Marker.t;
|
|
per_sel : iper -> bool;
|
|
fam_sel : ifam -> bool;
|
|
fam_done : (ifam, bool) Gwdb.Marker.t;
|
|
mutable notes_pl_p : person list;
|
|
mutable ext_files : (string * string list ref) list;
|
|
mutable notes_alias : (string * string) list;
|
|
mutable pevents_pl_p : person list;
|
|
}
|
|
|
|
let map_notes aliases f = try List.assoc f aliases with Not_found -> f
|
|
|
|
let add_linked_files gen from s some_linked_files =
|
|
let slen = String.length s in
|
|
let rec loop new_linked_files i =
|
|
if i = slen then new_linked_files
|
|
else if i < slen - 2 && s.[i] = '[' && s.[i + 1] = '[' && s.[i + 2] = '['
|
|
then
|
|
let j =
|
|
let rec loop j =
|
|
if j = slen then j
|
|
else if
|
|
j < slen - 2 && s.[j] = ']' && s.[j + 1] = ']' && s.[j + 2] = ']'
|
|
then j + 3
|
|
else loop (j + 1)
|
|
in
|
|
loop (i + 3)
|
|
in
|
|
if j > i + 6 then
|
|
let b = String.sub s (i + 3) (j - i - 6) in
|
|
let fname =
|
|
try
|
|
let k = String.index b '/' in
|
|
String.sub b 0 k
|
|
with Not_found -> b
|
|
in
|
|
let fname = map_notes gen.notes_alias fname in
|
|
let f = from () in
|
|
let new_linked_files =
|
|
try
|
|
let r = List.assoc fname gen.ext_files in
|
|
if List.mem f !r then () else r := f :: !r;
|
|
new_linked_files
|
|
with Not_found ->
|
|
let lf = (fname, ref [ f ]) in
|
|
gen.ext_files <- lf :: gen.ext_files;
|
|
lf :: new_linked_files
|
|
in
|
|
loop new_linked_files j
|
|
else loop new_linked_files (i + 1)
|
|
else loop new_linked_files (i + 1)
|
|
in
|
|
loop some_linked_files 0
|
|
|
|
let print_parent opts base gen p =
|
|
let has_printed_parents =
|
|
match get_parents p with Some ifam -> gen.fam_sel ifam | None -> false
|
|
in
|
|
let first_parent_definition =
|
|
if Gwdb.Marker.get gen.mark (get_iper p) then false
|
|
else (
|
|
Gwdb.Marker.set gen.mark (get_iper p) true;
|
|
true)
|
|
in
|
|
let pr = (not has_printed_parents) && first_parent_definition in
|
|
let has_infos = if pr then has_infos opts base p else false in
|
|
let first_name = sou base (get_first_name p) in
|
|
let surname = sou base (get_surname p) in
|
|
Printf.ksprintf (oc opts) "%s %s%s" (s_correct_string surname)
|
|
(s_correct_string first_name)
|
|
(if first_name = "?" && surname = "?" then ""
|
|
else if get_new_occ p = 0 then ""
|
|
else "." ^ string_of_int (get_new_occ p));
|
|
if pr then
|
|
if has_infos then print_infos opts base false "" "" p
|
|
else if first_name <> "?" && surname <> "?" then
|
|
Printf.ksprintf (oc opts) " 0"
|
|
|
|
let print_child opts base fam_surname csrc cbp p =
|
|
Printf.ksprintf (oc opts) "-";
|
|
(match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " h"
|
|
| Female -> Printf.ksprintf (oc opts) " f"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) " %s"
|
|
(s_correct_string (sou base (get_first_name p)));
|
|
if p_first_name base p = "?" && p_surname base p = "?" then ()
|
|
else if get_new_occ p = 0 then ()
|
|
else Printf.ksprintf (oc opts) ".%d" (get_new_occ p);
|
|
if not (eq_istr (get_surname p) fam_surname) then
|
|
Printf.ksprintf (oc opts) " %s"
|
|
(s_correct_string_nonum (sou base (get_surname p)));
|
|
print_infos opts base true csrc cbp p;
|
|
Printf.ksprintf (oc opts) "\n"
|
|
|
|
let bogus_person base p = p_first_name base p = "?" && p_surname base p = "?"
|
|
|
|
let common_children proj base children =
|
|
if Array.length children <= 1 then None
|
|
else
|
|
let list = List.map (fun p -> sou base (proj p)) (Array.to_list children) in
|
|
if List.mem "" list then None
|
|
else
|
|
let list = List.sort compare list in
|
|
let src_max, n_max, _, _ =
|
|
List.fold_left
|
|
(fun (src_max, n_max, prev_src, n) src ->
|
|
if src = prev_src then
|
|
let n = n + 1 in
|
|
if n > n_max then (src, n, src, n) else (src_max, n_max, src, n)
|
|
else (src_max, n_max, src, 1))
|
|
("", 0, "", 0) list
|
|
in
|
|
if n_max > 1 then Some src_max else None
|
|
|
|
let common_children_sources = common_children get_psources
|
|
let common_children_birth_place = common_children get_birth_place
|
|
|
|
let empty_family base m =
|
|
bogus_person base m.m_fath && bogus_person base m.m_moth
|
|
&& Array.for_all (bogus_person base) m.m_chil
|
|
|
|
let string_of_witness_kind :
|
|
Def.witness_kind -> ('a, unit, string, unit) format4 option = function
|
|
| Witness_GodParent -> Some "#godp"
|
|
| Witness -> None
|
|
| Witness_CivilOfficer -> Some "#offi"
|
|
| Witness_ReligiousOfficer -> Some "#reli"
|
|
| Witness_Informant -> Some "#info"
|
|
| Witness_Attending -> Some "#atte"
|
|
| Witness_Mentioned -> Some "#ment"
|
|
| Witness_Other -> Some "#othe"
|
|
|
|
let print_witness opts base gen p =
|
|
Printf.ksprintf (oc opts) "%s %s%s"
|
|
(correct_string base (get_surname p))
|
|
(correct_string base (get_first_name p))
|
|
(if get_new_occ p = 0 then "" else "." ^ string_of_int (get_new_occ p));
|
|
if
|
|
Array.length (get_family p) = 0
|
|
&& get_parents p = None
|
|
&& not (Gwdb.Marker.get gen.mark (get_iper p))
|
|
then (
|
|
Gwdb.Marker.set gen.mark (get_iper p) true;
|
|
if has_infos opts base p then print_infos opts base false "" "" p
|
|
else Printf.ksprintf (oc opts) " 0";
|
|
(match sou base (get_notes p) with
|
|
| "" ->
|
|
if put_events_in_notes base p then gen.notes_pl_p <- p :: gen.notes_pl_p
|
|
| _ -> gen.notes_pl_p <- p :: gen.notes_pl_p);
|
|
if get_pevents p <> [] then gen.pevents_pl_p <- p :: gen.pevents_pl_p)
|
|
|
|
let print_pevent opts base gen e =
|
|
(match e.epers_name with
|
|
| Epers_Birth -> Printf.ksprintf (oc opts) "#birt"
|
|
| Epers_Baptism -> Printf.ksprintf (oc opts) "#bapt"
|
|
| Epers_Death -> Printf.ksprintf (oc opts) "#deat"
|
|
| Epers_Burial -> Printf.ksprintf (oc opts) "#buri"
|
|
| Epers_Cremation -> Printf.ksprintf (oc opts) "#crem"
|
|
| Epers_Accomplishment -> Printf.ksprintf (oc opts) "#acco"
|
|
| Epers_Acquisition -> Printf.ksprintf (oc opts) "#acqu"
|
|
| Epers_Adhesion -> Printf.ksprintf (oc opts) "#adhe"
|
|
| Epers_BaptismLDS -> Printf.ksprintf (oc opts) "#bapl"
|
|
| Epers_BarMitzvah -> Printf.ksprintf (oc opts) "#barm"
|
|
| Epers_BatMitzvah -> Printf.ksprintf (oc opts) "#basm"
|
|
| Epers_Benediction -> Printf.ksprintf (oc opts) "#bles"
|
|
| Epers_ChangeName -> Printf.ksprintf (oc opts) "#chgn"
|
|
| Epers_Circumcision -> Printf.ksprintf (oc opts) "#circ"
|
|
| Epers_Confirmation -> Printf.ksprintf (oc opts) "#conf"
|
|
| Epers_ConfirmationLDS -> Printf.ksprintf (oc opts) "#conl"
|
|
| Epers_Decoration -> Printf.ksprintf (oc opts) "#awar"
|
|
| Epers_DemobilisationMilitaire -> Printf.ksprintf (oc opts) "#demm"
|
|
| Epers_Diploma -> Printf.ksprintf (oc opts) "#degr"
|
|
| Epers_Distinction -> Printf.ksprintf (oc opts) "#dist"
|
|
| Epers_Dotation -> Printf.ksprintf (oc opts) "#endl"
|
|
| Epers_DotationLDS -> Printf.ksprintf (oc opts) "#dotl"
|
|
| Epers_Education -> Printf.ksprintf (oc opts) "#educ"
|
|
| Epers_Election -> Printf.ksprintf (oc opts) "#elec"
|
|
| Epers_Emigration -> Printf.ksprintf (oc opts) "#emig"
|
|
| Epers_Excommunication -> Printf.ksprintf (oc opts) "#exco"
|
|
| Epers_FamilyLinkLDS -> Printf.ksprintf (oc opts) "#flkl"
|
|
| Epers_FirstCommunion -> Printf.ksprintf (oc opts) "#fcom"
|
|
| Epers_Funeral -> Printf.ksprintf (oc opts) "#fune"
|
|
| Epers_Graduate -> Printf.ksprintf (oc opts) "#grad"
|
|
| Epers_Hospitalisation -> Printf.ksprintf (oc opts) "#hosp"
|
|
| Epers_Illness -> Printf.ksprintf (oc opts) "#illn"
|
|
| Epers_Immigration -> Printf.ksprintf (oc opts) "#immi"
|
|
| Epers_ListePassenger -> Printf.ksprintf (oc opts) "#lpas"
|
|
| Epers_MilitaryDistinction -> Printf.ksprintf (oc opts) "#mdis"
|
|
| Epers_MilitaryPromotion -> Printf.ksprintf (oc opts) "#mpro"
|
|
| Epers_MilitaryService -> Printf.ksprintf (oc opts) "#mser"
|
|
| Epers_MobilisationMilitaire -> Printf.ksprintf (oc opts) "#mobm"
|
|
| Epers_Naturalisation -> Printf.ksprintf (oc opts) "#natu"
|
|
| Epers_Occupation -> Printf.ksprintf (oc opts) "#occu"
|
|
| Epers_Ordination -> Printf.ksprintf (oc opts) "#ordn"
|
|
| Epers_Property -> Printf.ksprintf (oc opts) "#prop"
|
|
| Epers_Recensement -> Printf.ksprintf (oc opts) "#cens"
|
|
| Epers_Residence -> Printf.ksprintf (oc opts) "#resi"
|
|
| Epers_Retired -> Printf.ksprintf (oc opts) "#reti"
|
|
| Epers_ScellentChildLDS -> Printf.ksprintf (oc opts) "#slgc"
|
|
| Epers_ScellentParentLDS -> Printf.ksprintf (oc opts) "#slgp"
|
|
| Epers_ScellentSpouseLDS -> Printf.ksprintf (oc opts) "#slgs"
|
|
| Epers_VenteBien -> Printf.ksprintf (oc opts) "#vteb"
|
|
| Epers_Will -> Printf.ksprintf (oc opts) "#will"
|
|
| Epers_Name s -> Printf.ksprintf (oc opts) "#%s" (correct_string base s));
|
|
Printf.ksprintf (oc opts) " ";
|
|
let epers_date = Date.od_of_cdate e.epers_date in
|
|
print_date_option opts epers_date;
|
|
print_if_no_empty opts base "#p" e.epers_place;
|
|
(* TODO *)
|
|
(*print_if_no_empty opts base "#c" e.epers_cause;*)
|
|
if opts.source = None then print_if_no_empty opts base "#s" e.epers_src;
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Array.iter
|
|
(fun (ip, wk) ->
|
|
if gen.per_sel ip then (
|
|
let p = poi base ip in
|
|
Printf.ksprintf (oc opts) "wit";
|
|
(match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " m"
|
|
| Female -> Printf.ksprintf (oc opts) " f"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) ": ";
|
|
let sk = string_of_witness_kind wk in
|
|
(match sk with
|
|
| Some s -> Printf.ksprintf (oc opts) (s ^^ " ")
|
|
| None -> ());
|
|
print_witness opts base gen p;
|
|
Printf.ksprintf (oc opts) "\n"))
|
|
e.epers_witnesses;
|
|
let note = if opts.no_notes <> `nnn then sou base e.epers_note else "" in
|
|
if note <> "" then
|
|
List.iter
|
|
(fun line -> Printf.ksprintf (oc opts) "note %s\n" line)
|
|
(lines_list_of_string note)
|
|
|
|
let get_persons_with_pevents m list =
|
|
let fath = m.m_fath in
|
|
let moth = m.m_moth in
|
|
let list =
|
|
match (get_pevents fath, get_parents fath) with
|
|
| [], _ | _, Some _ -> list
|
|
| _ -> fath :: list
|
|
in
|
|
let list =
|
|
match (get_pevents moth, get_parents moth) with
|
|
| [], _ | _, Some _ -> list
|
|
| _ -> moth :: list
|
|
in
|
|
Array.fold_right
|
|
(fun p list -> if get_pevents p = [] then list else p :: list)
|
|
m.m_chil list
|
|
|
|
let print_pevents_for_person opts base gen p =
|
|
let pevents = get_pevents p in
|
|
let surn = s_correct_string (p_surname base p) in
|
|
let fnam = s_correct_string (p_first_name base p) in
|
|
if pevents <> [] && surn <> "?" && fnam <> "?" then (
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Printf.ksprintf (oc opts) "pevt %s %s%s\n" surn fnam
|
|
(if get_new_occ p = 0 then "" else "." ^ string_of_int (get_new_occ p));
|
|
List.iter (print_pevent opts base gen) pevents;
|
|
Printf.ksprintf (oc opts) "end pevt\n")
|
|
|
|
let rec list_memf f x = function
|
|
| [] -> false
|
|
| a :: l -> f x a || list_memf f x l
|
|
|
|
let eq_key p1 p2 = get_iper p1 = get_iper p2
|
|
let eq_key_fst (p1, _) (p2, _) = get_iper p1 = get_iper p2
|
|
|
|
let print_pevents opts base gen ml =
|
|
let pl = List.fold_right get_persons_with_pevents ml gen.pevents_pl_p in
|
|
let pl =
|
|
List.fold_right
|
|
(fun p pl -> if list_memf eq_key p pl then pl else p :: pl)
|
|
pl []
|
|
in
|
|
List.iter
|
|
(fun p ->
|
|
if gen.per_sel (get_iper p) then print_pevents_for_person opts base gen p)
|
|
pl
|
|
|
|
let print_fevent opts base gen in_comment e =
|
|
let print_sep () =
|
|
if not in_comment then Printf.ksprintf (oc opts) "\n"
|
|
else Printf.ksprintf (oc opts) " "
|
|
in
|
|
(match e.efam_name with
|
|
| Efam_Marriage -> Printf.ksprintf (oc opts) "#marr"
|
|
| Efam_NoMarriage -> Printf.ksprintf (oc opts) "#nmar"
|
|
| Efam_NoMention -> Printf.ksprintf (oc opts) "#nmen"
|
|
| Efam_Engage -> Printf.ksprintf (oc opts) "#enga"
|
|
| Efam_Divorce -> Printf.ksprintf (oc opts) "#div"
|
|
| Efam_Separated -> Printf.ksprintf (oc opts) "#sep"
|
|
| Efam_Annulation -> Printf.ksprintf (oc opts) "#anul"
|
|
| Efam_MarriageBann -> Printf.ksprintf (oc opts) "#marb"
|
|
| Efam_MarriageContract -> Printf.ksprintf (oc opts) "#marc"
|
|
| Efam_MarriageLicense -> Printf.ksprintf (oc opts) "#marl"
|
|
| Efam_PACS -> Printf.ksprintf (oc opts) "#pacs"
|
|
| Efam_Residence -> Printf.ksprintf (oc opts) "#resi"
|
|
| Efam_Name n -> Printf.ksprintf (oc opts) "#%s" (correct_string base n));
|
|
Printf.ksprintf (oc opts) " ";
|
|
let efam_date = Date.od_of_cdate e.efam_date in
|
|
print_date_option opts efam_date;
|
|
print_if_no_empty opts base "#p" e.efam_place;
|
|
(*print_if_no_empty opts base "#c" e.efam_cause;*)
|
|
if opts.source = None then print_if_no_empty opts base "#s" e.efam_src;
|
|
print_sep ();
|
|
Array.iter
|
|
(fun (ip, wk) ->
|
|
if gen.per_sel ip then (
|
|
let p = poi base ip in
|
|
Printf.ksprintf (oc opts) "wit";
|
|
(match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " m"
|
|
| Female -> Printf.ksprintf (oc opts) " f"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) ": ";
|
|
let sk = string_of_witness_kind wk in
|
|
(match sk with
|
|
| Some s -> Printf.ksprintf (oc opts) (s ^^ " ")
|
|
| None -> ());
|
|
print_witness opts base gen p;
|
|
print_sep ()))
|
|
e.efam_witnesses;
|
|
let note = if opts.no_notes <> `nnn then sou base e.efam_note else "" in
|
|
if note <> "" then
|
|
List.iter
|
|
(fun line ->
|
|
Printf.ksprintf (oc opts) "note %s" line;
|
|
print_sep ())
|
|
(lines_list_of_string note)
|
|
|
|
let print_comment_for_family opts base gen fam =
|
|
let comm = if opts.no_notes <> `nnn then sou base (get_comment fam) else "" in
|
|
(* Si on est en mode old_gw, on mets tous les évènements dans les notes. *)
|
|
(* On supprime les 2 évènements principaux. *)
|
|
let fevents =
|
|
List.filter
|
|
(fun evt ->
|
|
match evt.efam_name with
|
|
| Efam_Divorce | Efam_Engage | Efam_Marriage | Efam_NoMarriage
|
|
| Efam_NoMention | Efam_Separated ->
|
|
false
|
|
| _ -> true)
|
|
(get_fevents fam)
|
|
in
|
|
let has_evt =
|
|
!old_gw && (fevents <> [] || sou base (get_marriage_note fam) <> "")
|
|
in
|
|
if comm <> "" || has_evt then (
|
|
Printf.ksprintf (oc opts) "comm";
|
|
if comm <> "" then Printf.ksprintf (oc opts) " %s" (no_newlines comm);
|
|
if !old_gw then (
|
|
if sou base (get_marriage_note fam) <> "" then
|
|
Printf.ksprintf (oc opts) " marriage: %s"
|
|
(no_newlines (sou base (get_marriage_note fam)));
|
|
List.iter
|
|
(fun e ->
|
|
Printf.ksprintf (oc opts) " ";
|
|
print_fevent opts base gen true e)
|
|
fevents);
|
|
Printf.ksprintf (oc opts) "\n")
|
|
|
|
let print_empty_family opts base p =
|
|
let string_quest = Gwdb.insert_string base "?" in
|
|
Printf.ksprintf (oc opts) "fam ? ?.0 + #noment ? ?.0\n";
|
|
Printf.ksprintf (oc opts) "beg\n";
|
|
print_child opts base string_quest "" "" p;
|
|
Printf.ksprintf (oc opts) "end\n"
|
|
|
|
let print_family opts base gen m =
|
|
let fam = m.m_fam in
|
|
Printf.ksprintf (oc opts) "fam ";
|
|
print_parent opts base gen m.m_fath;
|
|
Printf.ksprintf (oc opts) " +";
|
|
print_date_option opts (Date.od_of_cdate (get_marriage fam));
|
|
let print_sexes s =
|
|
let c x =
|
|
match get_sex x with Male -> 'm' | Female -> 'f' | Neuter -> '?'
|
|
in
|
|
Printf.ksprintf (oc opts) " %s %c%c" s (c m.m_fath) (c m.m_moth)
|
|
in
|
|
(match get_relation fam with
|
|
| Married -> ()
|
|
| NotMarried -> Printf.ksprintf (oc opts) " #nm"
|
|
| Engaged -> Printf.ksprintf (oc opts) " #eng"
|
|
| NoSexesCheckNotMarried -> print_sexes "#nsck"
|
|
| NoSexesCheckMarried -> print_sexes "#nsckm"
|
|
| NoMention -> print_sexes "#noment"
|
|
| MarriageBann -> print_sexes "#banns"
|
|
| MarriageContract -> print_sexes "#contract"
|
|
| MarriageLicense -> print_sexes "#license"
|
|
| Pacs -> print_sexes "#pacs"
|
|
| Residence -> print_sexes "#residence");
|
|
print_if_no_empty opts base "#mp" (get_marriage_place fam);
|
|
if opts.source = None then
|
|
print_if_no_empty opts base "#ms" (get_marriage_src fam);
|
|
(match get_divorce fam with
|
|
| NotDivorced -> ()
|
|
| Separated -> Printf.ksprintf (oc opts) " #sep"
|
|
| Divorced d ->
|
|
let d = Date.od_of_cdate d in
|
|
Printf.ksprintf (oc opts) " -";
|
|
print_date_option opts d);
|
|
Printf.ksprintf (oc opts) " ";
|
|
print_parent opts base gen m.m_moth;
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Array.iter
|
|
(fun ip ->
|
|
if gen.per_sel ip then (
|
|
let p = poi base ip in
|
|
Printf.ksprintf (oc opts) "wit";
|
|
(match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " m"
|
|
| Female -> Printf.ksprintf (oc opts) " f"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) ": ";
|
|
print_witness opts base gen p;
|
|
Printf.ksprintf (oc opts) "\n"))
|
|
(get_witnesses fam);
|
|
(match opts.source with
|
|
| None ->
|
|
if sou base (get_fsources fam) <> "" then
|
|
Printf.ksprintf (oc opts) "src %s\n"
|
|
(correct_string base (get_fsources fam))
|
|
| Some "" -> ()
|
|
| Some x -> Printf.ksprintf (oc opts) "src %s\n" (s_correct_string x));
|
|
let csrc =
|
|
match common_children_sources base m.m_chil with
|
|
| Some s ->
|
|
Printf.ksprintf (oc opts) "csrc %s\n" (s_correct_string s);
|
|
s
|
|
| _ -> ""
|
|
in
|
|
let cbp =
|
|
match common_children_birth_place base m.m_chil with
|
|
| Some s ->
|
|
Printf.ksprintf (oc opts) "cbp %s\n" (s_correct_string s);
|
|
s
|
|
| _ -> ""
|
|
in
|
|
print_comment_for_family opts base gen fam;
|
|
if (not !old_gw) && get_fevents fam <> [] then (
|
|
Printf.ksprintf (oc opts) "fevt\n";
|
|
List.iter (print_fevent opts base gen false) (get_fevents fam);
|
|
Printf.ksprintf (oc opts) "end fevt\n");
|
|
(match Array.length m.m_chil with
|
|
| 0 -> ()
|
|
| _ ->
|
|
let fam_surname = get_surname m.m_fath in
|
|
Printf.ksprintf (oc opts) "beg\n";
|
|
Array.iter
|
|
(fun p ->
|
|
if gen.per_sel (get_iper p) then
|
|
print_child opts base fam_surname csrc cbp p)
|
|
m.m_chil;
|
|
Printf.ksprintf (oc opts) "end\n");
|
|
Gwdb.Marker.set gen.fam_done m.m_ifam true;
|
|
let f _ =
|
|
Printf.sprintf "family \"%s.%d %s\" & \"%s.%d %s\""
|
|
(p_first_name base m.m_fath)
|
|
(get_new_occ m.m_fath) (p_surname base m.m_fath)
|
|
(p_first_name base m.m_moth)
|
|
(get_new_occ m.m_moth) (p_surname base m.m_moth)
|
|
in
|
|
let s =
|
|
let sl =
|
|
let acc =
|
|
[ get_comment fam; get_marriage_note fam; get_marriage_src fam ]
|
|
in
|
|
if opts.source = None then get_fsources fam :: acc else acc
|
|
in
|
|
let sl =
|
|
if not !old_gw then
|
|
let rec loop l accu =
|
|
match l with
|
|
| [] -> accu
|
|
| evt :: l ->
|
|
let acc =
|
|
evt.efam_note
|
|
:: (if opts.source = None then evt.efam_src :: accu else accu)
|
|
in
|
|
loop l acc
|
|
in
|
|
loop (get_fevents fam) sl
|
|
else sl
|
|
in
|
|
String.concat " " (List.map (sou base) sl)
|
|
in
|
|
ignore (add_linked_files gen f s [] : _ list)
|
|
|
|
let get_persons_with_notes m list =
|
|
let list =
|
|
let fath = m.m_fath in
|
|
match get_parents fath with Some _ -> list | None -> fath :: list
|
|
in
|
|
let list =
|
|
let moth = m.m_moth in
|
|
match get_parents moth with Some _ -> list | None -> moth :: list
|
|
in
|
|
Array.fold_right List.cons m.m_chil list
|
|
|
|
let notes_aliases bdir =
|
|
let fname = Filename.concat bdir "notes.alias" in
|
|
match try Some (Secure.open_in fname) with Sys_error _ -> None with
|
|
| Some ic ->
|
|
let rec loop list =
|
|
match try Some (input_line ic) with End_of_file -> None with
|
|
| Some s ->
|
|
let list =
|
|
try
|
|
let i = String.index s ' ' in
|
|
( String.sub s 0 i,
|
|
String.sub s (i + 1) (String.length s - i - 1) )
|
|
:: list
|
|
with Not_found -> list
|
|
in
|
|
loop list
|
|
| None ->
|
|
close_in ic;
|
|
list
|
|
in
|
|
loop []
|
|
| None -> []
|
|
|
|
let print_notes_for_person opts base gen p =
|
|
let print_witness_in_notes witnesses =
|
|
Array.iter
|
|
(fun (ip, wk) ->
|
|
let p = poi base ip in
|
|
Printf.ksprintf (oc opts) "wit";
|
|
(match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " m"
|
|
| Female -> Printf.ksprintf (oc opts) " f"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) ": ";
|
|
let sk = string_of_witness_kind wk in
|
|
(match sk with
|
|
| Some s -> Printf.ksprintf (oc opts) (s ^^ " ")
|
|
| None -> ());
|
|
print_witness opts base gen p;
|
|
Printf.ksprintf (oc opts) "\n")
|
|
witnesses
|
|
in
|
|
let epers_name_to_string evt =
|
|
match evt.epers_name with
|
|
| Epers_Birth -> "birth"
|
|
| Epers_Baptism -> "baptism"
|
|
| Epers_Death -> "death"
|
|
| Epers_Burial -> "burial"
|
|
| Epers_Cremation -> "cremation"
|
|
| _ -> ""
|
|
in
|
|
let notes = if opts.no_notes <> `nnn then sou base (get_notes p) else "" in
|
|
let surn = s_correct_string (p_surname base p) in
|
|
let fnam = s_correct_string (p_first_name base p) in
|
|
(* Si on n'est en mode old_gw, on mets tous les évènements dans les notes. *)
|
|
if (notes <> "" || put_events_in_notes base p) && surn <> "?" && fnam <> "?"
|
|
then (
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Printf.ksprintf (oc opts) "notes %s %s%s\n" surn fnam
|
|
(if get_new_occ p = 0 then "" else "." ^ string_of_int (get_new_occ p));
|
|
Printf.ksprintf (oc opts) "beg\n";
|
|
if notes <> "" then Printf.ksprintf (oc opts) "%s\n" notes;
|
|
(if put_events_in_notes base p then
|
|
let rec loop pevents =
|
|
match pevents with
|
|
| [] -> ()
|
|
| evt :: events -> (
|
|
match evt.epers_name with
|
|
| Epers_Birth | Epers_Baptism | Epers_Death | Epers_Burial
|
|
| Epers_Cremation ->
|
|
let name = epers_name_to_string evt in
|
|
let notes =
|
|
if opts.no_notes <> `nnn then sou base evt.epers_note else ""
|
|
in
|
|
if notes <> "" then
|
|
Printf.ksprintf (oc opts) "%s: %s\n" name notes;
|
|
print_witness_in_notes evt.epers_witnesses;
|
|
loop events
|
|
| _ ->
|
|
print_pevent opts base gen evt;
|
|
loop events)
|
|
in
|
|
loop (get_pevents p));
|
|
Printf.ksprintf (oc opts) "end notes\n");
|
|
let f _ =
|
|
Printf.sprintf "person \"%s.%d %s\"" (p_first_name base p) (get_new_occ p)
|
|
(p_surname base p)
|
|
in
|
|
let s =
|
|
let aux g = sou base (g p) in
|
|
let sl =
|
|
if opts.no_notes <> `nnn then
|
|
[
|
|
aux get_notes;
|
|
aux get_birth_note;
|
|
aux get_baptism_note;
|
|
aux get_death_note;
|
|
aux get_burial_note;
|
|
]
|
|
else []
|
|
in
|
|
let sl =
|
|
match opts.source with
|
|
| Some "" -> sl
|
|
| Some src -> src :: sl
|
|
| None ->
|
|
aux get_birth_src :: aux get_baptism_src :: aux get_death_src
|
|
:: aux get_burial_src :: aux get_psources :: sl
|
|
in
|
|
if (not !old_gw) && opts.source = None then
|
|
List.fold_left
|
|
(fun acc e ->
|
|
let acc =
|
|
if opts.no_notes <> `nnn then sou base e.epers_note :: acc else acc
|
|
in
|
|
let acc =
|
|
if opts.source = None then sou base e.epers_src :: acc else acc
|
|
in
|
|
acc)
|
|
sl (get_pevents p)
|
|
else sl
|
|
in
|
|
let s = String.concat " " s in
|
|
ignore (add_linked_files gen f s [] : _ list)
|
|
|
|
let print_notes opts base gen ml =
|
|
let pl = List.fold_right get_persons_with_notes ml gen.notes_pl_p in
|
|
let pl =
|
|
List.fold_right
|
|
(fun p pl -> if list_memf eq_key p pl then pl else p :: pl)
|
|
pl []
|
|
in
|
|
List.iter
|
|
(fun p ->
|
|
if gen.per_sel (get_iper p) then print_notes_for_person opts base gen p)
|
|
pl
|
|
|
|
let is_isolated p =
|
|
match get_parents p with
|
|
| Some _ -> false
|
|
| None -> Array.length (get_family p) = 0
|
|
|
|
let is_definition_for_parent p =
|
|
match get_parents p with Some _ -> false | None -> true
|
|
|
|
let get_isolated_related base m list =
|
|
let concat_isolated p_relation ip list =
|
|
let p = poi base ip in
|
|
if List.mem_assq p list then list
|
|
else if is_isolated p then
|
|
match get_rparents p with
|
|
| { r_fath = Some x } :: _ when x = get_iper p_relation ->
|
|
list @ [ (p, true) ]
|
|
| { r_fath = None; r_moth = Some x } :: _ when x = get_iper p_relation ->
|
|
list @ [ (p, true) ]
|
|
| _ -> list
|
|
else list
|
|
in
|
|
let list =
|
|
if is_definition_for_parent m.m_fath then
|
|
List.fold_right (concat_isolated m.m_fath) (get_related m.m_fath) list
|
|
else list
|
|
in
|
|
let list =
|
|
if is_definition_for_parent m.m_moth then
|
|
List.fold_right (concat_isolated m.m_moth) (get_related m.m_moth) list
|
|
else list
|
|
in
|
|
Array.fold_right
|
|
(fun p list -> List.fold_right (concat_isolated p) (get_related p) list)
|
|
m.m_chil list
|
|
|
|
let get_persons_with_relations base m list =
|
|
let fath = m.m_fath in
|
|
let moth = m.m_moth in
|
|
let list =
|
|
match (get_rparents fath, get_parents fath) with
|
|
| [], _ | _, Some _ -> list
|
|
| _ -> (fath, false) :: list
|
|
in
|
|
let list =
|
|
match (get_rparents moth, get_parents moth) with
|
|
| [], _ | _, Some _ -> list
|
|
| _ -> (moth, false) :: list
|
|
in
|
|
let list =
|
|
Array.fold_right
|
|
(fun ip list ->
|
|
let p = poi base ip in
|
|
match (get_rparents p, get_parents p) with
|
|
| [], _ | _, Some _ -> list
|
|
| { r_fath = Some x } :: _, _ when x <> get_iper m.m_fath -> list
|
|
| _ -> (p, false) :: list)
|
|
(get_witnesses m.m_fam) list
|
|
in
|
|
Array.fold_right
|
|
(fun p list ->
|
|
match get_rparents p with [] -> list | _ -> (p, false) :: list)
|
|
m.m_chil list
|
|
|
|
let print_relation_parent opts base mark defined_p p =
|
|
Printf.ksprintf (oc opts) "%s %s%s"
|
|
(correct_string base (get_surname p))
|
|
(correct_string base (get_first_name p))
|
|
(if get_new_occ p = 0 then "" else "." ^ string_of_int (get_new_occ p));
|
|
if
|
|
Array.length (get_family p) = 0
|
|
&& get_parents p = None
|
|
&& not (Gwdb.Marker.get mark (get_iper p))
|
|
then (
|
|
Gwdb.Marker.set mark (get_iper p) true;
|
|
if has_infos opts base p then print_infos opts base false "" "" p
|
|
else Printf.ksprintf (oc opts) " 0";
|
|
defined_p := p :: !defined_p)
|
|
|
|
let print_relation_for_person opts base gen def_p r =
|
|
let fath =
|
|
match r.r_fath with
|
|
| Some ip ->
|
|
if gen.per_sel ip then
|
|
let p = poi base ip in
|
|
if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?"
|
|
then None
|
|
else Some p
|
|
else None
|
|
| None -> None
|
|
in
|
|
let moth =
|
|
match r.r_moth with
|
|
| Some ip ->
|
|
if gen.per_sel ip then
|
|
let p = poi base ip in
|
|
if sou base (get_first_name p) = "?" || sou base (get_surname p) = "?"
|
|
then None
|
|
else Some p
|
|
else None
|
|
| None -> None
|
|
in
|
|
let err_same_sex =
|
|
match (fath, moth) with
|
|
| Some fath, Some moth -> get_sex fath = get_sex moth
|
|
| _ -> false
|
|
in
|
|
let print_err_one_relation p =
|
|
Printf.ksprintf (oc opts) "- ";
|
|
(match r.r_type with
|
|
| Adoption -> Printf.ksprintf (oc opts) "adop"
|
|
| Recognition -> Printf.ksprintf (oc opts) "reco"
|
|
| CandidateParent -> Printf.ksprintf (oc opts) "cand"
|
|
| GodParent -> Printf.ksprintf (oc opts) "godp"
|
|
| FosterParent -> Printf.ksprintf (oc opts) "fost");
|
|
if get_sex p = Male then Printf.ksprintf (oc opts) " fath"
|
|
else Printf.ksprintf (oc opts) " moth";
|
|
Printf.ksprintf (oc opts) ": ";
|
|
print_relation_parent opts base gen.mark def_p p;
|
|
Printf.ksprintf (oc opts) "\n"
|
|
in
|
|
match (fath, moth) with
|
|
| None, None -> ()
|
|
| _ ->
|
|
if err_same_sex then
|
|
match (fath, moth) with
|
|
| Some fath, Some moth ->
|
|
print_err_one_relation fath;
|
|
print_err_one_relation moth
|
|
| _ -> ()
|
|
else (
|
|
Printf.ksprintf (oc opts) "- ";
|
|
(match r.r_type with
|
|
| Adoption -> Printf.ksprintf (oc opts) "adop"
|
|
| Recognition -> Printf.ksprintf (oc opts) "reco"
|
|
| CandidateParent -> Printf.ksprintf (oc opts) "cand"
|
|
| GodParent -> Printf.ksprintf (oc opts) "godp"
|
|
| FosterParent -> Printf.ksprintf (oc opts) "fost");
|
|
(match (fath, moth) with
|
|
| Some fath, None ->
|
|
if get_sex fath = Male then Printf.ksprintf (oc opts) " fath"
|
|
else Printf.ksprintf (oc opts) " moth"
|
|
| None, Some moth ->
|
|
if get_sex moth = Female then Printf.ksprintf (oc opts) " moth"
|
|
else Printf.ksprintf (oc opts) " fath"
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) ": ";
|
|
(match (fath, moth) with
|
|
| Some fath, None -> print_relation_parent opts base gen.mark def_p fath
|
|
| None, Some moth -> print_relation_parent opts base gen.mark def_p moth
|
|
| Some fath, Some moth ->
|
|
if get_sex fath = Male && get_sex moth = Female then (
|
|
print_relation_parent opts base gen.mark def_p fath;
|
|
Printf.ksprintf (oc opts) " + ";
|
|
print_relation_parent opts base gen.mark def_p moth)
|
|
else (
|
|
print_relation_parent opts base gen.mark def_p moth;
|
|
Printf.ksprintf (oc opts) " + ";
|
|
print_relation_parent opts base gen.mark def_p fath)
|
|
| _ -> ());
|
|
Printf.ksprintf (oc opts) "\n")
|
|
|
|
let print_relations_for_person opts base gen def_p is_definition p =
|
|
let surn = correct_string base (get_surname p) in
|
|
let fnam = correct_string base (get_first_name p) in
|
|
let exist_relation =
|
|
List.exists
|
|
(fun r ->
|
|
match (r.r_fath, r.r_moth) with
|
|
| Some ip1, Some ip2 -> gen.per_sel ip1 && gen.per_sel ip2
|
|
| Some ip1, _ -> gen.per_sel ip1
|
|
| _, Some ip2 -> gen.per_sel ip2
|
|
| _ -> false)
|
|
(get_rparents p)
|
|
in
|
|
if
|
|
surn <> "?" && fnam <> "?" && exist_relation
|
|
&& not (Gwdb.Marker.get gen.mark_rel (get_iper p))
|
|
then (
|
|
Gwdb.Marker.set gen.mark_rel (get_iper p) true;
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Printf.ksprintf (oc opts) "rel %s %s%s" surn fnam
|
|
(if get_new_occ p = 0 then "" else "." ^ string_of_int (get_new_occ p));
|
|
if is_definition then (
|
|
Gwdb.Marker.set gen.mark (get_iper p) true;
|
|
def_p := p :: !def_p;
|
|
if has_infos opts base p then print_infos opts base false "" "" p
|
|
else Printf.ksprintf (oc opts) " 0";
|
|
match get_sex p with
|
|
| Male -> Printf.ksprintf (oc opts) " #h"
|
|
| Female -> Printf.ksprintf (oc opts) " #f"
|
|
| Neuter -> ());
|
|
Printf.ksprintf (oc opts) "\n";
|
|
Printf.ksprintf (oc opts) "beg\n";
|
|
List.iter (print_relation_for_person opts base gen def_p) (get_rparents p);
|
|
Printf.ksprintf (oc opts) "end\n")
|
|
|
|
let print_relations opts base gen ml =
|
|
let pl = List.fold_right (get_persons_with_relations base) ml [] in
|
|
let pl = List.fold_right (get_isolated_related base) ml pl in
|
|
let pl =
|
|
List.fold_right
|
|
(fun p pl -> if list_memf eq_key_fst p pl then pl else p :: pl)
|
|
pl []
|
|
in
|
|
let rec loop = function
|
|
| [] -> ()
|
|
| (p, if_def) :: pl ->
|
|
let def_p = ref [] in
|
|
if get_rparents p <> [] && gen.per_sel (get_iper p) then (
|
|
print_relations_for_person opts base gen def_p if_def p;
|
|
List.iter (print_notes_for_person opts base gen) !def_p;
|
|
if not !old_gw then
|
|
List.iter (print_pevents_for_person opts base gen) !def_p);
|
|
loop (pl @ List.map (fun p -> (p, false)) !def_p)
|
|
in
|
|
loop pl
|
|
|
|
let print_isolated_relations opts base gen p =
|
|
let pl = [ (p, false) ] in
|
|
let pl =
|
|
List.fold_right
|
|
(fun p pl -> if list_memf eq_key_fst p pl then pl else p :: pl)
|
|
pl []
|
|
in
|
|
let rec loop = function
|
|
| [] -> ()
|
|
| (p, if_def) :: pl ->
|
|
let def_p = ref [] in
|
|
if get_rparents p <> [] && gen.per_sel (get_iper p) then (
|
|
print_relations_for_person opts base gen def_p if_def p;
|
|
List.iter (print_notes_for_person opts base gen) !def_p);
|
|
loop (pl @ List.map (fun p -> (p, false)) !def_p)
|
|
in
|
|
loop pl
|
|
|
|
let rec merge_families ifaml1f ifaml2f =
|
|
match (ifaml1f, ifaml2f) with
|
|
| ifam1 :: ifaml1, ifam2 :: ifaml2 ->
|
|
let m1 = List.mem ifam1 ifaml2 in
|
|
let m2 = List.mem 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 ifam2 < ifam1 then ifam2 :: ifam1 :: merge_families ifaml1 ifaml2
|
|
else if ifam1 < ifam2 then ifam1 :: ifam2 :: merge_families ifaml1 ifaml2
|
|
else ifam1 :: merge_families ifaml1 ifaml2
|
|
| ifaml1, [] -> ifaml1
|
|
| [], ifaml2 -> ifaml2
|
|
|
|
(* let connected_families base fam_sel ifam cpl =
|
|
* let rec loop ifaml scanned =
|
|
* function
|
|
* | ip :: ipl ->
|
|
* let scanned = ip :: scanned in
|
|
* let ipl, ifaml =
|
|
* Array.fold_right begin fun i (acci, accf) ->
|
|
* if fam_sel i && not @@ List.mem i accf
|
|
* then
|
|
* let accf = i :: accf in
|
|
* let cpl = foi base ifam in
|
|
* let fa = get_father cpl in
|
|
* let mo = get_mother cpl in
|
|
* let acci =
|
|
* if not @@ List.mem fa acci
|
|
* && not @@ List.mem fa scanned
|
|
* then fa :: acci
|
|
* else acci
|
|
* in
|
|
* let acci =
|
|
* if not @@ List.mem mo acci
|
|
* && not @@ List.mem mo scanned
|
|
* then mo :: acci
|
|
* else acci
|
|
* in
|
|
* (acci, accf)
|
|
* else (acci, accf)
|
|
* end (get_family @@ poi base ip) (ipl, ifaml)
|
|
* in
|
|
* loop ifaml scanned ipl
|
|
* | [] -> ifaml
|
|
* in
|
|
* loop [ ifam ] [] [ get_father cpl ; get_mother cpl ]
|
|
* |> List.sort_uniq compare *)
|
|
|
|
let rec filter f = function
|
|
| x :: l -> if f x then x :: filter f l else filter f l
|
|
| [] -> []
|
|
|
|
let connected_families base fam_sel ifam cpl =
|
|
let rec loop ifaml ipl_scanned = function
|
|
| ip :: ipl ->
|
|
if List.mem 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 ifaml1 = filter fam_sel ifaml1 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 read_file_contents fname =
|
|
match try Some (open_in fname) with Sys_error _ -> None with
|
|
| Some ic -> (
|
|
let len = ref 0 in
|
|
try
|
|
let rec loop () =
|
|
len := Buff.store !len (input_char ic);
|
|
loop ()
|
|
in
|
|
loop ()
|
|
with End_of_file -> Buff.get !len)
|
|
| None -> ""
|
|
|
|
type separate = ToSeparate | NotScanned | BeingScanned | Scanned
|
|
|
|
let rec find_ancestors base surn p list =
|
|
match get_parents p with
|
|
| Some ifam ->
|
|
let cpl = foi base ifam in
|
|
let fath = poi base (get_father cpl) in
|
|
let moth = poi base (get_mother cpl) in
|
|
if
|
|
(not (eq_istr (get_surname fath) surn))
|
|
&& not (eq_istr (get_surname moth) surn)
|
|
then p :: list
|
|
else
|
|
let list =
|
|
if eq_istr (get_surname fath) surn then
|
|
find_ancestors base surn fath list
|
|
else list
|
|
in
|
|
if eq_istr (get_surname moth) surn then
|
|
find_ancestors base surn moth list
|
|
else list
|
|
| None -> p :: list
|
|
|
|
let mark_branch base mark surn p =
|
|
let rec loop top p =
|
|
for i = 0 to Array.length (get_family p) - 1 do
|
|
let ifam = (get_family p).(i) in
|
|
if Gwdb.Marker.get mark ifam = NotScanned then
|
|
let ifaml =
|
|
connected_families base (fun _ -> true) ifam (foi base ifam)
|
|
in
|
|
let children =
|
|
List.fold_left
|
|
(fun list ifam ->
|
|
let desc = foi base ifam in
|
|
Array.fold_left
|
|
(fun list ip -> poi base ip :: list)
|
|
list (get_children desc))
|
|
[] ifaml
|
|
in
|
|
if top || List.exists (fun p -> eq_istr (get_surname p) surn) children
|
|
then (
|
|
List.iter (fun ifam -> Gwdb.Marker.set mark ifam ToSeparate) ifaml;
|
|
List.iter (loop false) children)
|
|
done
|
|
in
|
|
loop true p
|
|
|
|
let mark_someone base mark s =
|
|
match Gutil.person_ht_find_all base s with
|
|
| [ ip ] ->
|
|
let p = poi base ip in
|
|
let plist = find_ancestors base (get_surname p) p [] in
|
|
List.iter (mark_branch base mark (get_surname p)) plist
|
|
| [] ->
|
|
Printf.eprintf "Error: \"%s\" is not found\n" s;
|
|
flush stderr;
|
|
exit 2
|
|
| _ ->
|
|
Printf.eprintf "Error: several answers for \"%s\"\n" s;
|
|
flush stderr;
|
|
exit 2
|
|
|
|
let scan_connex_component base test_action len ifam =
|
|
let rec loop len ifam =
|
|
let fam = foi base ifam in
|
|
let fath = poi base (get_father fam) in
|
|
let moth = poi base (get_mother fam) in
|
|
let len =
|
|
Array.fold_left
|
|
(fun len ifam1 ->
|
|
if ifam1 = ifam then len else test_action loop len ifam1)
|
|
len (get_family fath)
|
|
in
|
|
let len =
|
|
Array.fold_left
|
|
(fun len ifam1 ->
|
|
if ifam1 = ifam then len else test_action loop len ifam1)
|
|
len (get_family moth)
|
|
in
|
|
let len =
|
|
match get_parents fath with
|
|
| Some ifam -> test_action loop len ifam
|
|
| _ -> len
|
|
in
|
|
let len =
|
|
match get_parents moth with
|
|
| Some ifam -> test_action loop len ifam
|
|
| _ -> len
|
|
in
|
|
let children = get_children fam in
|
|
Array.fold_left
|
|
(fun len ip ->
|
|
Array.fold_left (test_action loop) len (get_family (poi base ip)))
|
|
len children
|
|
in
|
|
loop len ifam
|
|
|
|
let mark_one_connex_component base mark ifam =
|
|
let origin_file = sou base (get_origin_file (foi base ifam)) in
|
|
let test_action loop len ifam =
|
|
if
|
|
Gwdb.Marker.get mark ifam = NotScanned
|
|
&& sou base (get_origin_file (foi base ifam)) = origin_file
|
|
then (
|
|
Gwdb.Marker.set mark ifam BeingScanned;
|
|
loop (len + 1) ifam)
|
|
else len
|
|
in
|
|
let _ = test_action (fun _ _ -> 1) 0 ifam in
|
|
let len = 1 + scan_connex_component base test_action 0 ifam in
|
|
let set_mark x =
|
|
let test_action loop () ifam =
|
|
if Gwdb.Marker.get mark ifam = BeingScanned then (
|
|
Gwdb.Marker.set mark ifam x;
|
|
loop () ifam)
|
|
in
|
|
test_action (fun _ _ -> ()) () ifam;
|
|
scan_connex_component base test_action () ifam
|
|
in
|
|
if len <= !sep_limit && (!only_file = "" || !only_file = origin_file) then
|
|
set_mark ToSeparate
|
|
else (
|
|
Printf.eprintf "%s: group of size %d not included\n" origin_file len;
|
|
let cpl = foi base ifam in
|
|
Printf.eprintf " %s + %s\n"
|
|
(Gutil.designation base (poi base (get_father cpl)))
|
|
(Gutil.designation base (poi base (get_mother cpl)));
|
|
flush stderr;
|
|
set_mark Scanned)
|
|
|
|
let mark_connex_components base mark ifam =
|
|
let test_action _loop _len ifam =
|
|
if Gwdb.Marker.get mark ifam = NotScanned then
|
|
mark_one_connex_component base mark ifam
|
|
in
|
|
scan_connex_component base test_action () ifam
|
|
|
|
let add_small_connex_components base mark =
|
|
Gwdb.Collection.iter
|
|
(fun i ->
|
|
if Gwdb.Marker.get mark i = ToSeparate then
|
|
mark_connex_components base mark i)
|
|
(Gwdb.ifams base)
|
|
|
|
let separate base =
|
|
match List.rev !separate_list with
|
|
| [] -> fun _ -> false
|
|
| list ->
|
|
let ifams = Gwdb.ifams base in
|
|
let mark = Gwdb.ifam_marker (Gwdb.ifams base) NotScanned in
|
|
List.iter (mark_someone base mark) list;
|
|
add_small_connex_components base mark;
|
|
let len =
|
|
Gwdb.Collection.fold
|
|
(fun acc i ->
|
|
if Gwdb.Marker.get mark i = ToSeparate then acc + 1 else acc)
|
|
0 ifams
|
|
in
|
|
Printf.eprintf "*** extracted %d families\n" len;
|
|
flush stderr;
|
|
fun ifam -> Gwdb.Marker.get mark ifam = ToSeparate
|
|
|
|
let rs_printf opts s =
|
|
let rec loop bol i =
|
|
if i = String.length s then ()
|
|
else if s.[i] = '\n' then (
|
|
Printf.ksprintf (oc opts) "\n";
|
|
loop true (i + 1))
|
|
else (
|
|
if bol then Printf.ksprintf (oc opts) " ";
|
|
Printf.ksprintf (oc opts) "%c" s.[i];
|
|
loop false (i + 1))
|
|
in
|
|
loop true 0
|
|
|
|
let gwu opts isolated base in_dir out_dir src_oc_ht (per_sel, fam_sel) =
|
|
if out_dir <> "" && not (Sys.file_exists out_dir) then Mutil.mkdir_p out_dir;
|
|
let to_separate = separate base in
|
|
let out_oc_first = ref true in
|
|
let _ofile, oc, close = opts.oc in
|
|
let origin_file fname =
|
|
if fname = "" || out_dir = "" then (oc, out_oc_first, close)
|
|
else
|
|
let fname = Filename.basename fname in
|
|
try Hashtbl.find src_oc_ht fname
|
|
with Not_found ->
|
|
let oc = open_out (Filename.concat out_dir fname) in
|
|
let ((out, _, _) as x) =
|
|
(output_string oc, ref true, fun () -> close_out oc)
|
|
in
|
|
if not !raw_output then out "encoding: utf-8\n";
|
|
if !old_gw then out "\n" else out "gwplus\n\n";
|
|
Hashtbl.add src_oc_ht fname x;
|
|
x
|
|
in
|
|
let gen =
|
|
let mark = Gwdb.iper_marker (Gwdb.ipers base) false in
|
|
let mark_rel = Gwdb.iper_marker (Gwdb.ipers base) false in
|
|
let fam_done = Gwdb.ifam_marker (Gwdb.ifams base) false in
|
|
{
|
|
mark;
|
|
mark_rel;
|
|
per_sel;
|
|
fam_sel;
|
|
fam_done;
|
|
notes_pl_p = [];
|
|
ext_files = [];
|
|
notes_alias = notes_aliases in_dir;
|
|
pevents_pl_p = [];
|
|
}
|
|
in
|
|
let nb_fam = nb_of_families base in
|
|
if !Mutil.verbose then ProgrBar.start ();
|
|
Gwdb.Collection.iteri
|
|
(fun i ifam ->
|
|
if !Mutil.verbose then ProgrBar.run i nb_fam;
|
|
if not (Gwdb.Marker.get gen.fam_done ifam) then
|
|
let fam = foi base ifam in
|
|
let ifaml = connected_families base gen.fam_sel ifam fam in
|
|
let oc, first, _close =
|
|
if to_separate ifam then (oc, out_oc_first, close)
|
|
else origin_file (sou base (get_origin_file fam))
|
|
in
|
|
let f, _ooc, c = opts.oc in
|
|
let opts = { opts with oc = (f, oc, c) } in
|
|
let ml =
|
|
List.fold_right
|
|
(fun ifam ml ->
|
|
let fam = foi base ifam in
|
|
let m =
|
|
{
|
|
m_ifam = ifam;
|
|
m_fam = fam;
|
|
m_fath = poi base (get_father fam);
|
|
m_moth = poi base (get_mother fam);
|
|
m_chil = Array.map (fun ip -> poi base ip) (get_children fam);
|
|
}
|
|
in
|
|
if empty_family base m then (
|
|
Gwdb.Marker.set gen.fam_done m.m_ifam true;
|
|
ml)
|
|
else m :: ml)
|
|
ifaml []
|
|
in
|
|
if ml <> [] then (
|
|
gen.notes_pl_p <- [];
|
|
gen.pevents_pl_p <- [];
|
|
if not !first then Printf.ksprintf oc "\n";
|
|
first := false;
|
|
List.iter (print_family opts base gen) ml;
|
|
print_notes opts base gen ml;
|
|
print_relations opts base gen ml;
|
|
if not !old_gw then print_pevents opts base gen ml))
|
|
(Gwdb.ifams ~select:gen.fam_sel base);
|
|
(* Ajout des personnes isolée à l'export. On leur ajoute des *)
|
|
(* parents pour pouvoir utiliser les autres fonctions normales. *)
|
|
(* Export que si c'est toute la base. *)
|
|
if isolated && opts.asc = None && opts.desc = None && opts.ascdesc = None then
|
|
Gwdb.Collection.iter
|
|
(fun i ->
|
|
if
|
|
(not @@ Gwdb.Marker.get gen.mark i)
|
|
&& (not @@ Gwdb.Marker.get gen.mark_rel i)
|
|
&& per_sel i
|
|
then
|
|
let p = poi base i in
|
|
match get_parents p with
|
|
| Some _ -> ()
|
|
| None ->
|
|
if
|
|
bogus_person base p
|
|
&& not
|
|
(get_birth p <> Date.cdate_None
|
|
|| get_baptism p <> Date.cdate_None
|
|
|| get_first_names_aliases p <> []
|
|
|| get_surnames_aliases p <> []
|
|
|| sou base (get_public_name p) <> ""
|
|
|| get_qualifiers p <> []
|
|
|| get_aliases p <> []
|
|
|| get_titles p <> []
|
|
|| sou base (get_occupation p) <> ""
|
|
|| sou base (get_birth_place p) <> ""
|
|
|| sou base (get_birth_src p) <> ""
|
|
|| sou base (get_baptism_place p) <> ""
|
|
|| sou base (get_baptism_src p) <> ""
|
|
|| sou base (get_death_place p) <> ""
|
|
|| sou base (get_death_src p) <> ""
|
|
|| sou base (get_burial_place p) <> ""
|
|
|| sou base (get_burial_src p) <> ""
|
|
|| sou base (get_notes p) <> ""
|
|
|| sou base (get_psources p) <> ""
|
|
|| get_rparents p <> []
|
|
|| get_related p <> [])
|
|
then ()
|
|
else
|
|
let oc, _first, _ = origin_file (base_notes_origin_file base) in
|
|
let f, _ooc, c = opts.oc in
|
|
let opts = { opts with oc = (f, oc, c) } in
|
|
Printf.ksprintf oc "\n";
|
|
print_empty_family opts base p;
|
|
print_notes_for_person opts base gen p;
|
|
Gwdb.Marker.set gen.mark i true;
|
|
print_isolated_relations opts base gen p)
|
|
(Gwdb.ipers base);
|
|
if !Mutil.verbose then ProgrBar.finish ();
|
|
if opts.no_notes = `none then (
|
|
let s = base_notes_read base "" in
|
|
let oc, first, _ = origin_file (base_notes_origin_file base) in
|
|
let f, _ooc, c = opts.oc in
|
|
let opts = { opts with oc = (f, oc, c) } in
|
|
if s <> "" then (
|
|
if not !first then Printf.ksprintf oc "\n";
|
|
first := false;
|
|
Printf.ksprintf oc "notes-db\n";
|
|
rs_printf opts s;
|
|
Printf.ksprintf oc "\nend notes-db\n";
|
|
ignore (add_linked_files gen (fun _ -> "database notes") s [] : _ list));
|
|
(try
|
|
let files =
|
|
Sys.readdir (Filename.concat in_dir (base_wiznotes_dir base))
|
|
in
|
|
Array.sort compare files;
|
|
for i = 0 to Array.length files - 1 do
|
|
let file = files.(i) in
|
|
if Filename.check_suffix file ".txt" then
|
|
let wfile =
|
|
List.fold_left Filename.concat in_dir
|
|
[ base_wiznotes_dir base; file ]
|
|
in
|
|
let s = read_file_contents wfile in
|
|
ignore
|
|
(add_linked_files gen (fun _ -> "wizard \"" ^ file ^ "\"") s []
|
|
: _ list)
|
|
done
|
|
with Sys_error _ -> ());
|
|
let rec loop = function
|
|
| [] -> ()
|
|
| (f, _) :: files ->
|
|
let fn =
|
|
match NotesLinks.check_file_name f with
|
|
| Some (dl, f) -> List.fold_right Filename.concat dl f
|
|
| None -> "bad"
|
|
in
|
|
let s = base_notes_read base fn in
|
|
let files =
|
|
add_linked_files gen
|
|
(fun _ -> Printf.sprintf "extended page \"%s\"" f)
|
|
s files
|
|
in
|
|
loop files
|
|
in
|
|
loop gen.ext_files;
|
|
List.iter
|
|
(fun (f, r) ->
|
|
let fn =
|
|
match NotesLinks.check_file_name f with
|
|
| Some (dl, f) -> List.fold_right Filename.concat dl f
|
|
| None -> "bad"
|
|
in
|
|
let s = String.trim (base_notes_read base fn) in
|
|
if s <> "" then (
|
|
if not !first then Printf.ksprintf oc "\n";
|
|
first := false;
|
|
Printf.ksprintf oc "# extended page \"%s\" used by:\n" f;
|
|
List.iter
|
|
(fun f -> Printf.ksprintf oc "# - %s\n" f)
|
|
(List.sort compare !r);
|
|
Printf.ksprintf oc "page-ext %s\n" f;
|
|
rs_printf opts s;
|
|
Printf.ksprintf oc "\nend page-ext\n"))
|
|
(List.sort compare gen.ext_files);
|
|
let close () =
|
|
flush_all ();
|
|
close ();
|
|
Hashtbl.iter (fun _ (_, _, close) -> close ()) src_oc_ht
|
|
in
|
|
try
|
|
let files =
|
|
Sys.readdir (Filename.concat in_dir (base_wiznotes_dir base))
|
|
in
|
|
Array.sort compare files;
|
|
for i = 0 to Array.length files - 1 do
|
|
let file = files.(i) in
|
|
if Filename.check_suffix file ".txt" then (
|
|
let wizid = Filename.chop_suffix file ".txt" in
|
|
let wfile =
|
|
List.fold_left Filename.concat in_dir
|
|
[ base_wiznotes_dir base; file ]
|
|
in
|
|
let s = String.trim (read_file_contents wfile) in
|
|
Printf.ksprintf oc "\nwizard-note %s\n" wizid;
|
|
rs_printf opts s;
|
|
Printf.ksprintf oc "\nend wizard-note\n")
|
|
done;
|
|
close ()
|
|
with Sys_error _ -> close ())
|