1(* $Id: gwdb.ml,v 5.244 2012-01-18 20:49:57 ddr Exp $ *)
2(* Copyright (c) 1998-2007 INRIA *)
3
4open Dbdisk;
5open Db2disk;
6open Def;
7open Futil;
8open Mutil;
9open Printf;
10
11type gen_string_person_index 'istr = Dbdisk.string_person_index 'istr ==
12  { find : 'istr -> list iper;
13    cursor : string -> 'istr;
14    next : 'istr -> 'istr }
15;
16
17value milazy_force f a (get, set) p =
18  match get p with
19  [ Some v -> v
20  | None -> do {
21      let v = f a in
22      set p (Some v);
23      v
24    } ]
25;
26
27value ht_find ht i = try Some (Hashtbl.find ht i) with [ Not_found -> None ];
28
29value no_person empty_string ip =
30  {first_name = empty_string; surname = empty_string; occ = 0;
31   image = empty_string; first_names_aliases = []; surnames_aliases = [];
32   public_name = empty_string; qualifiers = []; titles = []; rparents = [];
33   related = []; aliases = []; occupation = empty_string; sex = Neuter;
34   access = Private; birth = Adef.codate_None; birth_place = empty_string;
35   birth_src = empty_string; baptism = Adef.codate_None;
36   baptism_place = empty_string; baptism_src = empty_string;
37   death = DontKnowIfDead; death_place = empty_string;
38   death_src = empty_string; burial = UnknownBurial;
39   burial_place = empty_string; burial_src = empty_string;
40   notes = empty_string; psources = empty_string; key_index = ip}
41;
42value no_ascend = {parents = None; consang = Adef.no_consang};
43value no_union = {family = [| |]};
44
45(* Strings - common definitions *)
46
47type istr =
48  [ Istr of dsk_istr
49  | Istr2 of db2 and (string * string) and int
50  | Istr2New of db2 and string ]
51;
52
53type istr_fun 'a =
54  { is_empty_string : 'a -> bool;
55    is_quest_string : 'a -> bool;
56    un_istr : 'a -> Adef.istr;
57    un_istr2 : 'a -> string }
58;
59
60type relation = Def.gen_relation iper istr;
61type title = Def.gen_title istr;
62
63value eq_istr i1 i2 =
64  match (i1, i2) with
65  [ (Istr i1, Istr i2) -> Adef.int_of_istr i1 = Adef.int_of_istr i2
66  | (Istr2 _ (f11, f12) i1, Istr2 _ (f21, f22) i2) ->
67      i1 = i2 && f11 = f21 && f12 = f22
68  | (Istr2New _ s1, Istr2New _ s2) -> s1 = s2
69  | (Istr2 db2 f pos, Istr2New _ s2) -> string_of_istr2 db2 f pos = s2
70  | (Istr2New _ s1, Istr2 db2 f pos) -> s1 = string_of_istr2 db2 f pos
71  | _ -> failwith "eq_istr" ]
72;
73
74(* Strings - implementation database 1 *)
75
76value istr1_fun =
77  {is_empty_string istr = Adef.int_of_istr istr = 0;
78   is_quest_string istr = Adef.int_of_istr istr = 1;
79   un_istr i = i;
80   un_istr2 i = failwith "un_istr2 1"}
81;
82
83(* Strings - implementation database 2 *)
84
85value istr2_fun =
86  {is_empty_string (db2, path, pos) = string_of_istr2 db2 path pos = "";
87   is_quest_string (db2, path, pos) = string_of_istr2 db2 path pos = "?";
88   un_istr _ = failwith "un_istr";
89   un_istr2 (db2, path, pos) = string_of_istr2 db2 path pos}
90;
91
92value istr2new_fun =
93  {is_empty_string (db2, s) = s = "";
94   is_quest_string (db2, s) = s = "?";
95   un_istr (db2, s) = failwith "un_istr";
96   un_istr2 (db2, s) = s}
97;
98
99(* Strings - user functions *)
100
101value wrap_istr f g h =
102  fun
103  [ Istr istr -> f istr1_fun istr
104  | Istr2 db2 path pos -> g istr2_fun (db2, path, pos)
105  | Istr2New db2 s -> h istr2new_fun (db2, s) ]
106;
107
108value is_empty_string i =
109  let f pf = pf.is_empty_string in
110  wrap_istr f f f i
111;
112value is_quest_string i =
113  let f pf = pf.is_quest_string in
114  wrap_istr f f f i
115;
116value un_istr i =
117  let f pf = pf.un_istr in
118  wrap_istr f f f i
119;
120value un_istr2 i =
121  let f pf = pf.un_istr2 in
122  wrap_istr f f f i
123;
124
125(* String person index - common definitions *)
126
127type string_person_index =
128  [ Spi of gen_string_person_index dsk_istr
129  | Spi2 of db2 and string_person_index2 ]
130;
131
132type spi 'a =
133  { spi_first : 'a -> string -> istr;
134    spi_next : 'a -> istr -> bool -> (istr * int);
135    spi_find : 'a -> istr -> list iper }
136;
137
138(* String person index - implementation database 1 *)
139
140value spi1_fun =
141  {spi_first spi s = Istr (spi.cursor s);
142   spi_next spi istr need_whole_list =
143     match istr with
144     [ Istr s -> (Istr (spi.next s), 1)
145     | _ -> failwith "not impl spi_next" ];
146   spi_find spi s =
147     match s with
148     [ Istr s -> spi.find s
149     | _ -> failwith "not impl spi_find" ]}
150;
151
152(* String person index - implementation database 2 *)
153
154value spi2_fun =
155  {spi_first (db2, spi) s =
156     let f1 = "person" in
157     let f2 = if spi.is_first_name then "first_name" else "surname" in
158     match spi2_first db2 spi (f1, f2) s with
159     [ Sp pos -> Istr2 db2 (f1, f2) pos
160     | SpNew s2 -> Istr2New db2 s2 ]
161   ;
162   spi_next (db2, spi) istr need_whole_list =
163     let f1 = "person" in
164     let f2 = if spi.is_first_name then "first_name" else "surname" in
165     let (sp, dlen) = spi2_next db2 spi (f1, f2) need_whole_list in
166     let r =
167       match sp with
168       [ Sp pos -> Istr2 db2 (f1, f2) pos
169       | SpNew s2 -> Istr2New db2 s2 ]
170     in
171     (r, dlen);
172   spi_find (db2, spi) s =
173     match s with
174     [ Istr2 db2 (f1, f2) pos -> spi2_find db2 spi (f1, f2) pos
175     | Istr2New db2 s -> spi2gen_find db2 spi s
176     | _ -> failwith "not impl spi_find" ]}
177;
178
179(* String person index - user functions *)
180
181value wrap_spi f g =
182  fun
183  [ Spi spi -> f spi1_fun spi
184  | Spi2 db2 spi2 -> g spi2_fun (db2, spi2) ]
185;
186
187value spi_find =
188  let f pf = pf.spi_find in
189  wrap_spi f f
190;
191value spi_first =
192  let f pf = pf.spi_first in
193  wrap_spi f f
194;
195value spi_next =
196  let f pf = pf.spi_next in
197  wrap_spi f f
198;
199
200(* Persons - common definitions *)
201
202type person =
203  [ Person of dsk_base and int and person1_dat
204  | Person2 of db2 and int and person2_dat ]
205and person1_dat =
206  { per1 : mutable option dsk_person;
207    asc1 : mutable option dsk_ascend;
208    uni1 : mutable option dsk_union }
209and person2_dat =
210  { per2 : mutable option (option (gen_person iper string));
211    asc2 : mutable option (option (gen_ascend ifam));
212    uni2 : mutable option (option (gen_union ifam)) }
213;
214
215type person_fun 'p 'a 'u =
216  { get_access : 'p -> access;
217    get_aliases : 'p -> list istr;
218    get_baptism : 'p -> codate;
219    get_baptism_place : 'p -> istr;
220    get_baptism_src : 'p -> istr;
221    get_birth : 'p -> codate;
222    get_birth_place : 'p -> istr;
223    get_birth_src : 'p -> istr;
224    get_burial : 'p -> Def.burial;
225    get_burial_place : 'p -> istr;
226    get_burial_src : 'p -> istr;
227    get_death : 'p -> Def.death;
228    get_death_place : 'p -> istr;
229    get_death_src : 'p -> istr;
230    get_first_name : 'p -> istr;
231    get_first_names_aliases : 'p -> list istr;
232    get_image : 'p -> istr;
233    get_key_index : 'p -> iper;
234    get_notes : 'p -> istr;
235    get_occ : 'p -> int;
236    get_occupation : 'p -> istr;
237    get_psources : 'p -> istr;
238    get_public_name : 'p -> istr;
239    get_qualifiers : 'p -> list istr;
240    get_related : 'p -> list iper;
241    get_rparents : 'p -> list relation;
242    get_sex : 'p -> Def.sex;
243    get_surname : 'p -> istr;
244    get_surnames_aliases : 'p -> list istr;
245    get_titles : 'p -> list title;
246    gen_person_of_person : 'p -> Def.gen_person iper istr;
247    dsk_person_of_person : 'p -> Dbdisk.dsk_person;
248    get_consang : 'a -> Adef.fix;
249    get_parents : 'a -> option ifam;
250    get_family : 'u -> array ifam }
251;
252
253(* Persons - implementation database 1 *)
254
255value person1_fun =
256  {get_access p = p.Def.access;
257   get_aliases p = List.map (fun i -> Istr i) p.Def.aliases;
258   get_baptism p = p.Def.baptism;
259   get_baptism_place p = Istr p.Def.baptism_place;
260   get_baptism_src p = Istr p.Def.baptism_src; get_birth p = p.Def.birth;
261   get_birth_place p = Istr p.Def.birth_place;
262   get_birth_src p = Istr p.Def.birth_src; get_burial p = p.Def.burial;
263   get_burial_place p = Istr p.Def.burial_place;
264   get_burial_src p = Istr p.Def.burial_src; get_death p = p.Def.death;
265   get_death_place p = Istr p.Def.death_place;
266   get_death_src p = Istr p.Def.death_src;
267   get_first_name p = Istr p.Def.first_name;
268   get_first_names_aliases p =
269     List.map (fun i -> Istr i) p.Def.first_names_aliases;
270   get_image p = Istr p.Def.image; get_key_index p = p.Def.key_index;
271   get_notes p = Istr p.Def.notes; get_occ p = p.Def.occ;
272   get_occupation p = Istr p.Def.occupation;
273   get_psources p = Istr p.Def.psources;
274   get_public_name p = Istr p.Def.public_name;
275   get_qualifiers p = List.map (fun i -> Istr i) p.Def.qualifiers;
276   get_related p = p.Def.related;
277   get_rparents p =
278     List.map (map_relation_ps (fun x -> x) (fun i -> Istr i)) p.Def.rparents;
279   get_sex p = p.Def.sex; get_surname p = Istr p.Def.surname;
280   get_surnames_aliases p = List.map (fun i -> Istr i) p.Def.surnames_aliases;
281   get_titles p =
282     List.map (fun t -> map_title_strings (fun i -> Istr i) t) p.Def.titles;
283   gen_person_of_person p = map_person_ps (fun p -> p) (fun s -> Istr s) p;
284   dsk_person_of_person p = p;
285   get_consang a = a.Def.consang;
286   get_parents a = a.Def.parents;
287   get_family u = u.Def.family}
288;
289
290(* Persons - implementation database 2 *)
291
292value make_istr2 db2 path i = Istr2 db2 path (get_field_acc db2 i path);
293
294value get_list_field db2 i f1f2 =
295  let pos = get_field_acc db2 i f1f2 in
296  if pos = -1 then [] else get_field_data db2 pos f1f2 "data2.ext"
297;
298
299value sou2 i =
300  match i with
301  [ Istr2 db2 f pos -> string_of_istr2 db2 f pos
302  | Istr2New db2 s -> s
303  | _ -> assert False ]
304;
305
306value person2_fun =
307  self where rec self =
308    {get_access (db2, i) = get_field db2 i ("person", "access");
309     get_aliases (db2, i) =
310       let list = get_list_field db2 i ("person", "aliases") in
311       List.map (fun pos -> Istr2 db2 ("person", "aliases") pos) list;
312     get_baptism (db2, i) = get_field db2 i ("person", "baptism");
313     get_baptism_place (db2, i) =
314       make_istr2 db2 ("person", "baptism_place") i;
315     get_baptism_src (db2, i) = make_istr2 db2 ("person", "baptism_src") i;
316     get_birth (db2, i) = get_field db2 i ("person", "birth");
317     get_birth_place (db2, i) = make_istr2 db2 ("person", "birth_place") i;
318     get_birth_src (db2, i) = make_istr2 db2 ("person", "birth_src") i;
319     get_burial (db2, i) = get_field db2 i ("person", "burial");
320     get_burial_place (db2, i) = make_istr2 db2 ("person", "burial_place") i;
321     get_burial_src (db2, i) = make_istr2 db2 ("person", "burial_src") i;
322     get_death (db2, i) = get_field db2 i ("person", "death");
323     get_death_place (db2, i) = make_istr2 db2 ("person", "death_place") i;
324     get_death_src (db2, i) = make_istr2 db2 ("person", "death_src") i;
325     get_first_name (db2, i) = make_istr2 db2 ("person", "first_name") i;
326     get_first_names_aliases (db2, i) =
327       let list = get_list_field db2 i ("person", "first_names_aliases") in
328       List.map (fun pos -> Istr2 db2 ("person", "first_names_aliases") pos)
329         list;
330     get_image (db2, i) = make_istr2 db2 ("person", "image") i;
331     get_key_index (db2, i) = Adef.iper_of_int i;
332     get_notes (db2, i) = make_istr2 db2 ("person", "notes") i;
333     get_occ (db2, i) = get_field db2 i ("person", "occ");
334     get_occupation (db2, i) = make_istr2 db2 ("person", "occupation") i;
335     get_psources (db2, i) = make_istr2 db2 ("person", "psources") i;
336     get_public_name (db2, i) = make_istr2 db2 ("person", "public_name") i;
337     get_qualifiers (db2, i) =
338       let list = get_list_field db2 i ("person", "qualifiers") in
339       List.map (fun pos -> Istr2 db2 ("person", "qualifiers") pos) list;
340     get_related (db2, i) =
341       let pos = get_field_acc db2 i ("person", "related") in
342       let rec loop list pos =
343         if pos = -1 then List.rev list
344         else
345           let (ip, pos) =
346             get_field_2_data db2 pos ("person", "related") "data"
347           in
348           loop [ip :: list] pos
349       in
350       loop [] pos;
351     get_rparents (db2, i) =
352       let pos = get_field_acc db2 i ("person", "rparents") in
353       if pos = -1 then []
354       else
355         let rl = get_field_data db2 pos ("person", "rparents") "data" in
356         List.map
357           (map_relation_ps (fun x -> x) (fun _ -> Istr2 db2 ("", "") (-1)))
358           rl;
359     get_sex (db2, i) = get_field db2 i ("person", "sex");
360     get_surname (db2, i) = make_istr2 db2 ("person", "surname") i;
361     get_surnames_aliases (db2, i) =
362       let list = get_list_field db2 i ("person", "surnames_aliases") in
363       List.map (fun pos -> Istr2 db2 ("person", "surnames_aliases") pos)
364         list;
365     get_titles (db2, i) =
366       let list = get_list_field db2 i ("person", "titles") in
367       List.map
368         (map_title_strings (fun pos -> Istr2 db2 ("person", "titles") pos))
369         list;
370     gen_person_of_person pp =
371       {first_name = self.get_first_name pp; surname = self.get_surname pp;
372        occ = self.get_occ pp; image = self.get_image pp;
373        public_name = self.get_public_name pp;
374        qualifiers = self.get_qualifiers pp; aliases = self.get_aliases pp;
375        first_names_aliases = self.get_first_names_aliases pp;
376        surnames_aliases = self.get_surnames_aliases pp;
377        titles = self.get_titles pp; rparents = self.get_rparents pp;
378        related = self.get_related pp; occupation = self.get_occupation pp;
379        sex = self.get_sex pp; access = self.get_access pp;
380        birth = self.get_birth pp; birth_place = self.get_birth_place pp;
381        birth_src = self.get_birth_src pp; baptism = self.get_baptism pp;
382        baptism_place = self.get_baptism_place pp;
383        baptism_src = self.get_baptism_src pp; death = self.get_death pp;
384        death_place = self.get_death_place pp;
385        death_src = self.get_death_src pp; burial = self.get_burial pp;
386        burial_place = self.get_burial_place pp;
387        burial_src = self.get_burial_src pp; notes = self.get_notes pp;
388        psources = self.get_psources pp; key_index = self.get_key_index pp};
389     dsk_person_of_person p = failwith "not impl dsk_person_of_person";
390     get_consang (db2, i) =
391       match db2.consang_array with
392       [ Some tab -> tab.(i)
393       | None ->
394           let f = ("person", "consang") in
395           if field_exists db2 f then get_field db2 i f
396           else Adef.no_consang ];
397     get_parents (db2, i) =
398       match db2.parents_array with
399       [ Some tab -> tab.(i)
400       | None ->
401           let pos = get_field_acc db2 i ("person", "parents") in
402           if pos = -1 then None
403           else Some (get_field_data db2 pos ("person", "parents") "data") ];
404     get_family (db2, i) =
405       match db2.family_array with
406       [ Some tab -> tab.(i)
407       | None -> get_field db2 i ("person", "family") ]}
408;
409
410value person2gen_fun =
411  {get_access (db2, i, p) = p.Def.access;
412   get_aliases (db2, i, p) = List.map (fun s -> Istr2New db2 s) p.Def.aliases;
413   get_baptism (db2, i, p) = p.Def.baptism;
414   get_baptism_place (db2, i, p) = Istr2New db2 p.Def.baptism_place;
415   get_baptism_src (db2, i, p) = Istr2New db2 p.Def.baptism_src;
416   get_birth (db2, i, p) = p.Def.birth;
417   get_birth_place (db2, i, p) = Istr2New db2 p.Def.birth_place;
418   get_birth_src (db2, i, p) = Istr2New db2 p.Def.birth_src;
419   get_burial (db2, i, p) = p.Def.burial;
420   get_burial_place (db2, i, p) = Istr2New db2 p.Def.burial_place;
421   get_burial_src (db2, i, p) = Istr2New db2 p.Def.burial_src;
422   get_death (db2, i, p) = p.Def.death;
423   get_death_place (db2, i, p) = Istr2New db2 p.Def.death_place;
424   get_death_src (db2, i, p) = Istr2New db2 p.Def.death_src;
425   get_first_name (db2, i, p) = Istr2New db2 p.Def.first_name;
426   get_first_names_aliases (db2, i, p) =
427     List.map (fun s -> Istr2New db2 s) p.Def.first_names_aliases;
428   get_image (db2, i, p) = Istr2New db2 p.Def.image;
429   get_key_index (db2, i, p) = p.Def.key_index;
430   get_notes (db2, i, p) = Istr2New db2 p.Def.notes;
431   get_occ (db2, i, p) = p.Def.occ;
432   get_occupation (db2, i, p) = Istr2New db2 p.Def.occupation;
433   get_psources (db2, i, p) = Istr2New db2 p.Def.psources;
434   get_public_name (db2, i, p) = Istr2New db2 p.Def.public_name;
435   get_qualifiers (db2, i, p) =
436     List.map (fun s -> Istr2New db2 s) p.Def.qualifiers;
437   get_related (db2, i, p) = p.Def.related;
438   get_rparents (db2, i, p) =
439     List.map (map_relation_ps (fun x -> x) (fun s -> Istr2New db2 s))
440       p.Def.rparents;
441   get_sex (db2, i, p) = p.Def.sex;
442   get_surname (db2, i, p) = Istr2New db2 p.Def.surname;
443   get_surnames_aliases (db2, i, p) =
444     List.map (fun s -> Istr2New db2 s) p.Def.surnames_aliases;
445   get_titles (db2, i, p) =
446     List.map (fun t -> map_title_strings (fun s -> Istr2New db2 s) t)
447       p.Def.titles;
448   gen_person_of_person (db2, i, p) =
449     map_person_ps (fun p -> p) (fun s -> Istr2New db2 s) p;
450   dsk_person_of_person (db2, i, p) =
451     failwith "not impl dsk_person_of_person (gen)";
452   get_consang (db2, i, a) = a.Def.consang;
453   get_parents (db2, i, a) = a.Def.parents;
454   get_family (db2, i, u) = u.Def.family}
455;
456
457(* Persons - user functions *)
458
459value get_set_per1 = (fun p -> p.per1, fun p v -> p.per1 := v);
460value get_set_asc1 = (fun p -> p.asc1, fun p v -> p.asc1 := v);
461value get_set_uni1 = (fun p -> p.uni1, fun p v -> p.uni1 := v);
462
463value get_set_per2 = (fun p -> p.per2, fun p v -> p.per2 := v);
464value get_set_asc2 = (fun p -> p.asc2, fun p v -> p.asc2 := v);
465value get_set_uni2 = (fun p -> p.uni2, fun p v -> p.uni2 := v);
466
467value wrap_per f g h =
468  fun
469  [ Person base i p ->
470      let per = milazy_force base.data.persons.get i get_set_per1 p in
471      f person1_fun per
472  | Person2 db2 i p ->
473      let per =
474        milazy_force (ht_find db2.patches.h_person) (Adef.iper_of_int i)
475          get_set_per2 p
476      in
477      match per with
478      [ Some p -> h person2gen_fun (db2, i, p)
479      | None -> g person2_fun (db2, i) ] ]
480;
481
482value wrap_asc f g h =
483  fun
484  [ Person base i p ->
485      let asc = milazy_force base.data.ascends.get i get_set_asc1 p in
486      f person1_fun asc
487  | Person2 db2 i p ->
488      let asc =
489        milazy_force (ht_find db2.patches.h_ascend) (Adef.iper_of_int i)
490          get_set_asc2 p
491      in
492      match asc with
493      [ Some a -> h person2gen_fun (db2, i, a)
494      | None -> g person2_fun (db2, i) ] ]
495;
496
497value wrap_uni f g h =
498  fun
499  [ Person base i p ->
500      let uni = milazy_force base.data.unions.get i get_set_uni1 p in
501      f person1_fun uni
502  | Person2 db2 i p ->
503      let uni =
504        milazy_force (ht_find db2.patches.h_union) (Adef.iper_of_int i)
505          get_set_uni2 p
506      in
507      match uni with
508      [ Some u -> h person2gen_fun (db2, i, u)
509      | None -> g person2_fun (db2, i) ] ]
510;
511
512value get_access p =
513  let f pf = pf.get_access in
514  wrap_per f f f p
515;
516value get_aliases p =
517  let f pf = pf.get_aliases in
518  wrap_per f f f p
519;
520value get_baptism p =
521  let f pf = pf.get_baptism in
522  wrap_per f f f p
523;
524value get_baptism_place p =
525  let f pf = pf.get_baptism_place in
526  wrap_per f f f p
527;
528value get_baptism_src p =
529  let f pf = pf.get_baptism_src in
530  wrap_per f f f p
531;
532value get_birth p =
533  let f pf = pf.get_birth in
534  wrap_per f f f p
535;
536value get_birth_place p =
537  let f pf = pf.get_birth_place in
538  wrap_per f f f p
539;
540value get_birth_src p =
541  let f pf = pf.get_birth_src in
542  wrap_per f f f p
543;
544value get_burial p =
545  let f pf = pf.get_burial in
546  wrap_per f f f p
547;
548value get_burial_place p =
549  let f pf = pf.get_burial_place in
550  wrap_per f f f p
551;
552value get_burial_src p =
553  let f pf = pf.get_burial_src in
554  wrap_per f f f p
555;
556value get_death p =
557  let f pf = pf.get_death in
558  wrap_per f f f p
559;
560value get_death_place p =
561  let f pf = pf.get_death_place in
562  wrap_per f f f p
563;
564value get_death_src p =
565  let f pf = pf.get_death_src in
566  wrap_per f f f p
567;
568value get_first_name p =
569  let f pf = pf.get_first_name in
570  wrap_per f f f p
571;
572value get_first_names_aliases p =
573  let f pf = pf.get_first_names_aliases in
574  wrap_per f f f p
575;
576value get_image p =
577  let f pf = pf.get_image in
578  wrap_per f f f p
579;
580value get_key_index p =
581  let f pf = pf.get_key_index in
582  wrap_per f f f p
583;
584value get_notes p =
585  let f pf = pf.get_notes in
586  wrap_per f f f p
587;
588value get_occ p =
589  let f pf = pf.get_occ in
590  wrap_per f f f p
591;
592value get_occupation p =
593  let f pf = pf.get_occupation in
594  wrap_per f f f p
595;
596value get_psources p =
597  let f pf = pf.get_psources in
598  wrap_per f f f p
599;
600value get_public_name p =
601  let f pf = pf.get_public_name in
602  wrap_per f f f p
603;
604value get_qualifiers p =
605  let f pf = pf.get_qualifiers in
606  wrap_per f f f p
607;
608value get_related p =
609  let f pf = pf.get_related in
610  wrap_per f f f p
611;
612value get_rparents p =
613  let f pf = pf.get_rparents in
614  wrap_per f f f p
615;
616value get_sex p =
617  let f pf = pf.get_sex in
618  wrap_per f f f p
619;
620value get_surname p =
621  let f pf = pf.get_surname in
622  wrap_per f f f p
623;
624value get_surnames_aliases p =
625  let f pf = pf.get_surnames_aliases in
626  wrap_per f f f p
627;
628value get_titles p =
629  let f pf = pf.get_titles in
630  wrap_per f f f p
631;
632
633value gen_person_of_person p =
634  let f pf = pf.gen_person_of_person in
635  wrap_per f f f p
636;
637value dsk_person_of_person p =
638  let f pf = pf.dsk_person_of_person in
639  wrap_per f f f p
640;
641
642value get_consang a =
643  let f pf = pf.get_consang in
644  match a with
645  [ Person2 db2 i _ ->
646      match db2.consang_array with
647      [ Some tab -> tab.(i)
648      | None -> wrap_asc f f f a ]
649  | _ -> wrap_asc f f f a ]
650;
651value get_parents a =
652  let f pf = pf.get_parents in
653  match a with
654  [ Person2 db2 i _ ->
655      match db2.parents_array with
656      [ Some tab -> tab.(i)
657      | None -> wrap_asc f f f a ]
658  | _ -> wrap_asc f f f a ]
659;
660
661value get_family u =
662  let f pf = pf.get_family in
663  wrap_uni f f f u
664;
665
666(* Families - common definitions *)
667
668type family =
669  [ Family of dsk_base and int and family1_dat
670  | Family2 of db2 and int and family2_dat ]
671and family1_dat =
672  { fam1 : mutable option dsk_family;
673    cpl1 : mutable option dsk_couple;
674    des1 : mutable option dsk_descend }
675and family2_dat =
676  { fam2 : mutable option (option (gen_family iper string));
677    cpl2 : mutable option (option (gen_couple iper));
678    des2 : mutable option (option (gen_descend iper)) }
679;
680
681type family_fun 'f 'c 'd =
682  { get_comment : 'f -> istr;
683    get_divorce : 'f -> Def.divorce;
684    get_fsources : 'f -> istr;
685    get_marriage : 'f -> codate;
686    get_marriage_place : 'f -> istr;
687    get_marriage_src : 'f -> istr;
688    get_origin_file : 'f -> istr;
689    get_relation : 'f -> Def.relation_kind;
690    get_witnesses : 'f -> array iper;
691    gen_family_of_family : 'f -> Def.gen_family iper istr;
692    is_deleted_family : 'f -> bool;
693    get_father : 'c -> iper;
694    get_mother : 'c -> iper;
695    get_parent_array : 'c -> array iper;
696    gen_couple_of_couple : 'c -> Def.gen_couple iper;
697    get_children : 'd -> array iper;
698    gen_descend_of_descend : 'd -> Def.gen_descend iper }
699;
700
701(* Families - implementation database 1 *)
702
703value family1_fun =
704  {get_comment f = Istr f.Def.comment;
705   get_divorce f = f.Def.divorce;
706   get_fsources f = Istr f.Def.fsources;
707   get_marriage f = f.Def.marriage;
708   get_marriage_place f = Istr f.Def.marriage_place;
709   get_marriage_src f = Istr f.Def.marriage_src;
710   get_origin_file f = Istr f.Def.origin_file;
711   get_relation f = f.Def.relation;
712   get_witnesses f = f.Def.witnesses;
713   gen_family_of_family f = map_family_ps (fun p -> p) (fun s -> Istr s) f;
714   is_deleted_family f = f.Def.fam_index = Adef.ifam_of_int (-1);
715   get_father c = Adef.father c;
716   get_mother c = Adef.mother c;
717   get_parent_array c = Adef.parent_array c;
718   gen_couple_of_couple c = c;
719   get_children d = d.Def.children;
720   gen_descend_of_descend d = d}
721;
722
723(* Families - implementation database 2 *)
724
725value family2_fun =
726  self where rec self =
727    {get_comment (db2, i) = make_istr2 db2 ("family", "comment") i;
728     get_divorce (db2, i) = get_field db2 i ("family", "divorce");
729     get_fsources (db2, i) = make_istr2 db2 ("family", "fsources") i;
730     get_marriage (db2, i) = get_field db2 i ("family", "marriage");
731     get_marriage_place (db2, i) =
732       make_istr2 db2 ("family", "marriage_place") i;
733     get_marriage_src (db2, i) = make_istr2 db2 ("family", "marriage_src") i;
734     get_origin_file (db2, i) = make_istr2 db2 ("family", "origin_file") i;
735     get_relation (db2, i) = get_field db2 i ("family", "relation");
736     get_witnesses (db2, i) = get_field db2 i ("family", "witnesses");
737     gen_family_of_family ((db2, i) as f) =
738       {marriage = self.get_marriage f;
739        marriage_place = self.get_marriage_place f;
740        marriage_src = self.get_marriage_src f;
741        witnesses = self.get_witnesses f; relation = self.get_relation f;
742        divorce = self.get_divorce f; comment = self.get_comment f;
743        origin_file = self.get_origin_file f; fsources = self.get_fsources f;
744        fam_index = Adef.ifam_of_int i};
745     is_deleted_family (db2, i) =
746       let fath =
747         match db2.father_array with
748         [ Some tab -> tab.(i)
749         | None -> get_field db2 i ("family", "father") ]
750       in
751       Adef.int_of_iper fath < 0;
752     get_father (db2, i) =
753       match db2.father_array with
754       [ Some tab -> tab.(i)
755       | None -> get_field db2 i ("family", "father") ];
756     get_mother (db2, i) =
757       match db2.mother_array with
758       [ Some tab -> tab.(i)
759       | None -> get_field db2 i ("family", "mother") ];
760     get_parent_array (db2, i) =
761       let p1 = get_field db2 i ("family", "father") in
762       let p2 = get_field db2 i ("family", "mother") in
763       [| p1; p2 |];
764     gen_couple_of_couple c =
765       Adef.couple (self.get_father c) (self.get_mother c);
766     get_children (db2, i) =
767       match db2.children_array with
768       [ Some tab -> tab.(i)
769       | None -> get_field db2 i ("family", "children") ];
770     gen_descend_of_descend d = {children = self.get_children d}}
771;
772
773value family2gen_fun =
774  {get_comment (db2, f) = Istr2New db2 f.Def.comment;
775   get_divorce (db2, f) = f.Def.divorce;
776   get_fsources (db2, f) = Istr2New db2 f.Def.fsources;
777   get_marriage (db2, f) = f.Def.marriage;
778   get_marriage_place (db2, f) = Istr2New db2 f.Def.marriage_place;
779   get_marriage_src (db2, f) = Istr2New db2 f.Def.marriage_src;
780   get_origin_file (db2, f) = Istr2New db2 f.Def.origin_file;
781   get_relation (db2, f) = f.Def.relation;
782   get_witnesses (db2, f) = f.Def.witnesses;
783   gen_family_of_family (db2, f) =
784      map_family_ps (fun p -> p) (fun s -> Istr2New db2 s) f;
785   is_deleted_family (db2, f) = f.Def.fam_index = Adef.ifam_of_int (-1);
786   get_father (db2, c) = Adef.father c;
787   get_mother (db2, c) = Adef.mother c;
788   get_parent_array (db2, c) = Adef.parent_array c;
789   gen_couple_of_couple (db2, c) = c;
790   get_children (db2, d) = d.Def.children;
791   gen_descend_of_descend (db2, d) = d}
792;
793
794(* Families - user functions *)
795
796value get_set_fam1 = (fun p -> p.fam1, fun p v -> p.fam1 := v);
797value get_set_cpl1 = (fun p -> p.cpl1, fun p v -> p.cpl1 := v);
798value get_set_des1 = (fun p -> p.des1, fun p v -> p.des1 := v);
799
800value get_set_fam2 = (fun p -> p.fam2, fun p v -> p.fam2 := v);
801value get_set_cpl2 = (fun p -> p.cpl2, fun p v -> p.cpl2 := v);
802value get_set_des2 = (fun p -> p.des2, fun p v -> p.des2 := v);
803
804value wrap_fam f g h =
805  fun
806  [ Family base i d ->
807      let fam = milazy_force base.data.families.get i get_set_fam1 d in
808      f family1_fun fam
809  | Family2 db2 i d ->
810      let fam =
811        milazy_force (ht_find db2.patches.h_family) (Adef.ifam_of_int i)
812          get_set_fam2 d
813      in
814      match fam with
815      [ Some fam -> h family2gen_fun (db2, fam)
816      | None -> g family2_fun (db2, i) ] ]
817;
818
819value wrap_cpl f g h =
820  fun
821  [ Family base i d ->
822      let cpl = milazy_force base.data.couples.get i get_set_cpl1 d in
823      f family1_fun cpl
824  | Family2 db2 i d ->
825      let cpl =
826        milazy_force (ht_find db2.patches.h_couple) (Adef.ifam_of_int i)
827          get_set_cpl2 d
828      in
829      match cpl with
830      [ Some cpl -> h family2gen_fun (db2, cpl)
831      | None -> g family2_fun (db2, i) ] ]
832;
833
834value wrap_des f g h =
835  fun
836  [ Family base i d ->
837      let des = milazy_force base.data.descends.get i get_set_des1 d in
838      f family1_fun des
839  | Family2 db2 i d ->
840      let des =
841        milazy_force (ht_find db2.patches.h_descend) (Adef.ifam_of_int i)
842          get_set_des2 d
843      in
844      match des with
845      [ Some des -> h family2gen_fun (db2, des)
846      | None -> g family2_fun (db2, i) ] ]
847;
848
849value get_comment fam =
850  let f pf = pf.get_comment in
851  wrap_fam f f f fam
852;
853value get_divorce fam =
854  let f pf = pf.get_divorce in
855  wrap_fam f f f fam
856;
857value get_fsources fam =
858  let f pf = pf.get_fsources in
859  wrap_fam f f f fam
860;
861value get_marriage fam =
862  let f pf = pf.get_marriage in
863  wrap_fam f f f fam
864;
865value get_marriage_place fam =
866  let f pf = pf.get_marriage_place in
867  wrap_fam f f f fam
868;
869value get_marriage_src fam =
870  let f pf = pf.get_marriage_src in
871  wrap_fam f f f fam
872;
873value get_origin_file fam =
874  let f pf = pf.get_origin_file in
875  wrap_fam f f f fam
876;
877value get_relation fam =
878  let f pf = pf.get_relation in
879  wrap_fam f f f fam
880;
881value get_witnesses fam =
882  let f pf = pf.get_witnesses in
883  wrap_fam f f f fam
884;
885value gen_family_of_family fam =
886  let f pf = pf.gen_family_of_family in
887  wrap_fam f f f fam
888;
889value is_deleted_family fam =
890  let f pf = pf.is_deleted_family in
891  wrap_fam f f f fam
892;
893
894value get_father cpl =
895  let f pf = pf.get_father in
896  match cpl with
897  [ Family2 db2 i _ ->
898      match db2.father_array with
899      [ Some tab -> tab.(i)
900      | None -> wrap_cpl f f f cpl ]
901  | _ -> wrap_cpl f f f cpl ]
902;
903value get_mother cpl =
904  let f pf = pf.get_mother in
905  match cpl with
906  [ Family2 db2 i _ ->
907      match db2.mother_array with
908      [ Some tab -> tab.(i)
909      | None -> wrap_cpl f f f cpl ]
910  | _ -> wrap_cpl f f f cpl ]
911;
912value get_parent_array cpl =
913  let f pf = pf.get_parent_array in
914  wrap_cpl f f f cpl
915;
916value gen_couple_of_couple cpl =
917  let f pf = pf.gen_couple_of_couple in
918  wrap_cpl f f f cpl
919;
920
921value get_children des =
922  let f pf = pf.get_children in
923  wrap_des f f f des
924;
925value gen_descend_of_descend des =
926  let f pf = pf.gen_descend_of_descend in
927  wrap_des f f f des
928;
929
930(* Databases - common definitions *)
931
932type base =
933  { close_base : unit -> unit;
934    empty_person : iper -> person;
935    person_of_gen_person :
936      (gen_person iper istr * gen_ascend ifam * gen_union ifam) -> person;
937    family_of_gen_family :
938      (gen_family iper istr * gen_couple iper * gen_descend iper) -> family;
939    poi : iper -> person;
940    foi : ifam -> family;
941    sou : istr -> string;
942    nb_of_persons : unit -> int;
943    nb_of_families : unit -> int;
944    patch_person : iper -> Def.gen_person iper istr -> unit;
945    patch_ascend : iper -> Def.gen_ascend ifam -> unit;
946    patch_union : iper -> Def.gen_union ifam -> unit;
947    patch_family : ifam -> Def.gen_family iper istr -> unit;
948    patch_descend : ifam -> Def.gen_descend iper -> unit;
949    patch_couple : ifam -> Def.gen_couple iper -> unit;
950    patch_name : string -> iper -> unit;
951    patch_key : iper -> string -> string -> int -> unit;
952    delete_key : string -> string -> int -> unit;
953    insert_string : string -> istr;
954    commit_patches : unit -> unit;
955    commit_notes : string -> string -> unit;
956    is_patched_person : iper -> bool;
957    patched_ascends : unit -> list iper;
958    delete_family : ifam -> unit;
959    person_of_key : string -> string -> int -> option iper;
960    persons_of_name : string -> list iper;
961    persons_of_first_name : unit -> string_person_index;
962    persons_of_surname : unit -> string_person_index;
963    base_visible_get : (person -> bool) -> int -> bool;
964    base_visible_write : unit -> unit;
965    base_particles : unit -> list string;
966    base_strings_of_first_name : string -> list istr;
967    base_strings_of_surname : string -> list istr;
968    load_ascends_array : unit -> unit;
969    load_unions_array : unit -> unit;
970    load_couples_array : unit -> unit;
971    load_descends_array : unit -> unit;
972    load_strings_array : unit -> unit;
973    persons_array :
974      unit ->
975        (int -> gen_person iper istr *
976         int -> gen_person iper istr -> unit);
977    ascends_array :
978      unit ->
979        (int -> option ifam * int -> Adef.fix * int -> Adef.fix -> unit *
980         option (array Adef.fix));
981    base_notes_read : string -> string;
982    base_notes_read_first_line : string -> string;
983    base_notes_are_empty : string -> bool;
984    base_notes_origin_file : unit -> string;
985    base_notes_dir : unit -> string;
986    base_wiznotes_dir : unit -> string;
987    nobtit :
988      Lazy.t (list string) -> Lazy.t (list string) ->  person -> list title;
989    p_first_name : person -> string;
990    p_surname : person -> string;
991    date_of_last_change : unit -> float;
992    apply_base1 : (Dbdisk.dsk_base -> unit) -> unit;
993    apply_base2 : (Db2disk.db2 -> unit) -> unit }
994;
995
996module C_base :
997  sig
998    value delete_family : base -> ifam -> unit;
999    value nobtit :
1000      base -> Lazy.t (list string) -> Lazy.t (list string) -> person ->
1001        list title;
1002    value p_first_name : base -> person -> string;
1003    value p_surname : base -> person -> string;
1004  end =
1005  struct
1006    value delete_family self ifam = do {
1007      let cpl = Adef.couple (Adef.iper_of_int (-1)) (Adef.iper_of_int (-1)) in
1008      let fam =
1009        let empty = self.insert_string "" in
1010        {marriage = Adef.codate_None; marriage_place = empty;
1011         marriage_src = empty; relation = Married; divorce = NotDivorced;
1012         witnesses = [| |]; comment = empty; origin_file = empty;
1013         fsources = empty; fam_index = Adef.ifam_of_int (-1)}
1014      in
1015      let des = {children = [| |]} in
1016      self.patch_family ifam fam;
1017      self.patch_couple ifam cpl;
1018      self.patch_descend ifam des
1019    };
1020    value nobtit self allowed_titles denied_titles p =
1021      let list = get_titles p in
1022      match Lazy.force allowed_titles with
1023      [ [] -> list
1024      | allowed_titles ->
1025          let list =
1026            List.fold_right
1027              (fun t l ->
1028                 let id = Name.lower (self.sou t.t_ident) in
1029                 let pl = Name.lower (self.sou t.t_place) in
1030                 if pl = "" then
1031                   if List.mem id allowed_titles then [t :: l] else l
1032                 else if
1033                   List.mem (id ^ "/" ^ pl) allowed_titles ||
1034                   List.mem (id ^ "/*") allowed_titles
1035                 then
1036                   [t :: l]
1037                 else l)
1038              list []
1039          in
1040          match Lazy.force denied_titles with
1041          [ [] -> list
1042          | denied_titles ->
1043              List.filter
1044                (fun t ->
1045                   let id = Name.lower (self.sou t.t_ident) in
1046                   let pl = Name.lower (self.sou t.t_place) in
1047                   if List.mem (id ^ "/" ^ pl) denied_titles ||
1048                      List.mem ("*/" ^ pl) denied_titles
1049                   then
1050                     False
1051                   else True)
1052                list ] ]
1053    ;
1054    value p_first_name self p = nominative (self.sou (get_first_name p));
1055    value p_surname self p = nominative (self.sou (get_surname p));
1056  end
1057;
1058
1059(* Database - implementation 1 *)
1060
1061value base1 base =
1062  let base_strings_of_first_name_or_surname s =
1063    List.map (fun s -> Istr s) (base.func.strings_of_fsname s)
1064  in
1065  self where rec self =
1066    {close_base = base.func.cleanup;
1067     empty_person ip =
1068       Person base (Adef.int_of_iper ip)
1069         {per1 = Some (no_person (Adef.istr_of_int 0) ip);
1070          asc1 = Some no_ascend; uni1 = Some no_union};
1071     person_of_gen_person (p, a, u) =
1072       Person base 0
1073         {per1 = Some (map_person_ps (fun p -> p) un_istr p);
1074          asc1 = Some a; uni1 = Some u};
1075     family_of_gen_family (f, c, d) =
1076       Family base 0
1077         {fam1 = Some (map_family_ps (fun p -> p) un_istr f); cpl1 = Some c;
1078          des1 = Some d};
1079     poi i =
1080       Person base (Adef.int_of_iper i)
1081         {per1 = None; asc1 = None; uni1 = None};
1082     foi i =
1083       Family base (Adef.int_of_ifam i)
1084         {fam1 = None; cpl1 = None; des1 = None};
1085     sou i =
1086       match i with
1087       [ Istr i -> base.data.strings.get (Adef.int_of_istr i)
1088       | _ -> assert False ];
1089     nb_of_persons () = base.data.persons.len;
1090     nb_of_families () = base.data.families.len;
1091     patch_person ip p =
1092       let p = map_person_ps (fun p -> p) un_istr p in
1093       base.func.Dbdisk.patch_person ip p;
1094     patch_ascend ip a = base.func.Dbdisk.patch_ascend ip a;
1095     patch_union ip u = base.func.Dbdisk.patch_union ip u;
1096     patch_family ifam f =
1097       let f = map_family_ps (fun p -> p) un_istr f in
1098       base.func.Dbdisk.patch_family ifam f;
1099     patch_descend ifam d = base.func.Dbdisk.patch_descend ifam d;
1100     patch_couple ifam c = base.func.Dbdisk.patch_couple ifam c;
1101     patch_name s ip = base.func.Dbdisk.patch_name s ip;
1102     patch_key ip fn sn occ = ();
1103     delete_key fn sn occ = ();
1104     insert_string s = Istr (base.func.Dbdisk.insert_string s);
1105     commit_patches = base.func.Dbdisk.commit_patches;
1106     commit_notes = base.func.Dbdisk.commit_notes;
1107     is_patched_person ip = base.func.Dbdisk.is_patched_person ip;
1108     patched_ascends = base.func.Dbdisk.patched_ascends;
1109     delete_family ifam = C_base.delete_family self ifam;
1110     person_of_key = base.func.Dbdisk.person_of_key;
1111     persons_of_name = base.func.Dbdisk.persons_of_name;
1112     persons_of_first_name () = Spi base.func.Dbdisk.persons_of_first_name;
1113     persons_of_surname () = Spi base.func.Dbdisk.persons_of_surname;
1114     base_visible_get f =
1115       base.data.visible.v_get
1116         (fun p ->
1117            f (Person base 0 {per1 = Some p; asc1 = None; uni1 = None}));
1118     base_visible_write = base.data.visible.v_write;
1119     base_particles () = base.data.particles;
1120     base_strings_of_first_name = base_strings_of_first_name_or_surname;
1121     base_strings_of_surname = base_strings_of_first_name_or_surname;
1122     load_ascends_array = base.data.ascends.load_array;
1123     load_unions_array = base.data.unions.load_array;
1124     load_couples_array = base.data.couples.load_array;
1125     load_descends_array = base.data.descends.load_array;
1126     load_strings_array = base.data.strings.load_array;
1127     persons_array () =
1128       let get i =
1129         let p = base.data.persons.get i in
1130         map_person_ps (fun p -> p) (fun i -> Istr i) p
1131       in
1132       let set i p =
1133         let p = map_person_ps (fun p -> p) un_istr p in
1134         base.data.persons.set i p
1135       in
1136       (get, set);
1137     ascends_array () =
1138       let fget i = (base.data.ascends.get i).parents in
1139       let cget i = (base.data.ascends.get i).consang in
1140       let cset i v =
1141         base.data.ascends.set i {(base.data.ascends.get i) with consang = v}
1142       in
1143       (fget, cget, cset, None);
1144     base_notes_read fnotes = base.data.bnotes.nread fnotes RnAll;
1145     base_notes_read_first_line fnotes = base.data.bnotes.nread fnotes Rn1Ln;
1146     base_notes_are_empty fnotes = base.data.bnotes.nread fnotes RnDeg = "";
1147     base_notes_origin_file () = base.data.bnotes.norigin_file;
1148     base_notes_dir () = "notes_d"; base_wiznotes_dir () = "wiznotes";
1149     nobtit conf p = C_base.nobtit self conf p;
1150     p_first_name p = C_base.p_first_name self p;
1151     p_surname p = C_base.p_surname self p;
1152     date_of_last_change () =
1153       let s =
1154         let bdir = base.data.bdir in
1155         try Unix.stat (Filename.concat bdir "patches") with
1156         [ Unix.Unix_error _ _ _ -> Unix.stat (Filename.concat bdir "base") ]
1157       in
1158       s.Unix.st_mtime;
1159     apply_base1 f = f base;
1160     apply_base2 f = invalid_arg "apply_base2"}
1161;
1162
1163(* Database - implementation 2 *)
1164
1165value base2 db2 =
1166  let base_strings_of_first_name_or_surname field proj s =
1167    let posl = strings2_of_fsname db2 field s in
1168    let istrl = List.map (fun pos -> Istr2 db2 ("person", field) pos) posl in
1169    let s = Name.crush_lower s in
1170    let sl =
1171      Hashtbl.fold
1172        (fun _ p sl ->
1173           if Name.crush_lower (proj p) = s then [proj p :: sl] else sl)
1174        db2.patches.h_person []
1175    in
1176    let sl = list_uniq (List.sort compare sl) in
1177    List.fold_left (fun istrl s -> [Istr2New db2 s :: istrl]) istrl sl
1178  in
1179  self where rec self =
1180    {close_base () =
1181       Hashtbl.iter (fun (f1, f2, f) ic -> close_in ic) db2.cache_chan;
1182     empty_person ip =
1183       Person2 db2 (Adef.int_of_iper ip)
1184         {per2 = Some (Some (no_person "" ip)); asc2 = Some (Some no_ascend);
1185          uni2 = Some (Some no_union)};
1186     person_of_gen_person (p, a, u) =
1187       Person2 db2 (Adef.int_of_iper p.key_index)
1188         {per2 = Some (Some (map_person_ps (fun p -> p) un_istr2 p));
1189          asc2 = Some (Some a); uni2 = Some (Some u)};
1190     family_of_gen_family (f, c, d) =
1191       Family2 db2 (Adef.int_of_ifam f.fam_index)
1192         {fam2 = Some (Some (map_family_ps (fun p -> p) un_istr2 f));
1193          cpl2 = Some (Some c); des2 = Some (Some d)};
1194     poi i =
1195       Person2 db2 (Adef.int_of_iper i)
1196         {per2 = None; asc2 = None; uni2 = None};
1197     foi i =
1198       Family2 db2 (Adef.int_of_ifam i)
1199         {fam2 = None; cpl2 = None; des2 = None};
1200     sou i =
1201       match i with
1202       [ Istr2 db2 f pos -> string_of_istr2 db2 f pos
1203       | Istr2New db2 s -> s
1204       | _ -> assert False ];
1205     nb_of_persons () = db2.patches.nb_per;
1206     nb_of_families () = db2.patches.nb_fam;
1207     patch_person ip p = do {
1208       let p = map_person_ps (fun p -> p) un_istr2 p in
1209       Hashtbl.replace db2.patches.h_person ip p;
1210       db2.patches.nb_per := max (Adef.int_of_iper ip + 1) db2.patches.nb_per;
1211     };
1212     patch_ascend ip a = do {
1213       Hashtbl.replace db2.patches.h_ascend ip a;
1214       db2.patches.nb_per := max (Adef.int_of_iper ip + 1) db2.patches.nb_per;
1215     };
1216     patch_union ip u = do {
1217       Hashtbl.replace db2.patches.h_union ip u;
1218       db2.patches.nb_per := max (Adef.int_of_iper ip + 1) db2.patches.nb_per;
1219     };
1220     patch_family ifam f = do {
1221       let f = map_family_ps (fun p -> p) un_istr2 f in
1222       Hashtbl.replace db2.patches.h_family ifam f;
1223       db2.patches.nb_fam :=
1224         max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam
1225     };
1226     patch_descend ifam d = do {
1227       Hashtbl.replace db2.patches.h_descend ifam d;
1228       db2.patches.nb_fam :=
1229         max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam
1230     };
1231     patch_couple ifam c = do {
1232       Hashtbl.replace db2.patches.h_couple ifam c;
1233       db2.patches.nb_fam :=
1234         max (Adef.int_of_ifam ifam + 1) db2.patches.nb_fam
1235     };
1236     patch_name s ip =
1237       let s = Name.crush_lower s in
1238       let ht = db2.patches.h_name in
1239       try
1240         let ipl = Hashtbl.find ht s in
1241         if List.mem ip ipl then () else Hashtbl.replace ht s [ip :: ipl]
1242       with
1243       [ Not_found -> Hashtbl.add ht s [ip] ];
1244     patch_key ip fn sn occ =
1245       let fn = Name.lower (nominative fn) in
1246       let sn = Name.lower (nominative sn) in
1247       Hashtbl.replace db2.patches.h_key (fn, sn, occ) (Some ip);
1248     delete_key fn sn occ =
1249       let fn = Name.lower (nominative fn) in
1250       let sn = Name.lower (nominative sn) in
1251       match disk_person2_of_key db2 fn sn occ with
1252       [ Some _ -> Hashtbl.replace db2.patches.h_key (fn, sn, occ) None
1253       | None -> Hashtbl.remove db2.patches.h_key (fn, sn, occ) ];
1254     insert_string s = Istr2New db2 s;
1255     commit_patches () = commit_patches2 db2;
1256     commit_notes fnotes s = commit_notes2 db2 fnotes s;
1257     is_patched_person ip = Hashtbl.mem db2.patches.h_person ip;
1258     patched_ascends () = do {
1259       let r = ref [] in
1260       Hashtbl.iter (fun ip _ -> r.val := [ip :: r.val]) db2.patches.h_ascend;
1261       r.val
1262     };
1263     delete_family ifam = C_base.delete_family self ifam;
1264     person_of_key fn sn oc = person2_of_key db2 fn sn oc;
1265     persons_of_name s = persons2_of_name db2 s;
1266     persons_of_first_name () =
1267       Spi2 db2 (persons_of_first_name_or_surname2 db2 True);
1268     persons_of_surname () =
1269       Spi2 db2 (persons_of_first_name_or_surname2 db2 False);
1270     base_visible_get f = failwith "not impl visible_get";
1271     base_visible_write () = failwith "not impl visible_write";
1272     base_particles () =
1273       Mutil.input_particles (Filename.concat db2.bdir2 "particles.txt");
1274     base_strings_of_first_name s =
1275       base_strings_of_first_name_or_surname "first_name"
1276         (fun p -> p.first_name) s;
1277     base_strings_of_surname s =
1278       base_strings_of_first_name_or_surname "surname" (fun p -> p.surname) s;
1279     load_ascends_array () =
1280       do {
1281         eprintf "*** loading ascends array\n";
1282         flush stderr;
1283         let nb = db2.patches.nb_per in
1284         let nb_ini = db2.patches.nb_per_ini in
1285         match db2.parents_array with
1286         [ Some _ -> ()
1287         | None -> db2.parents_array := Some (parents_array2 db2 nb_ini nb) ];
1288         match db2.consang_array with
1289         [ Some _ -> ()
1290         | None -> db2.consang_array := Some (consang_array2 db2 nb) ];
1291       };
1292     load_unions_array () =
1293       match db2.family_array with
1294       [ Some _ -> ()
1295       | None ->
1296           do {
1297             eprintf "*** loading unions array\n";
1298             flush stderr;
1299             db2.family_array := Some (family_array2 db2)
1300           } ];
1301     load_couples_array () = load_couples_array2 db2;
1302     load_descends_array () =
1303       match db2.children_array with
1304       [ Some _ -> ()
1305       | None ->
1306           do {
1307             eprintf "*** loading descends array\n";
1308             flush stderr;
1309             db2.children_array := Some (children_array2 db2)
1310           } ];
1311     load_strings_array () = ();
1312     persons_array () = failwith "not impl persons_array";
1313     ascends_array () =
1314       let nb = db2.patches.nb_per in
1315       let nb_ini = db2.patches.nb_per_ini in
1316       let ptab =
1317         match db2.parents_array with
1318         [ Some tab -> tab
1319         | None -> parents_array2 db2 nb_ini nb ]
1320       in
1321       let cg_tab =
1322         match db2.consang_array with
1323         [ Some tab -> tab
1324         | None -> consang_array2 db2 nb ]
1325       in
1326       let fget i = ptab.(i) in
1327       let cget i = cg_tab.(i) in
1328       let cset i v = cg_tab.(i) := v in
1329       (fget, cget, cset, Some cg_tab);
1330     base_notes_read fnotes = read_notes db2 fnotes RnAll;
1331     base_notes_read_first_line fnotes = read_notes db2 fnotes Rn1Ln;
1332     base_notes_are_empty fnotes = read_notes db2 fnotes RnDeg = "";
1333     base_notes_origin_file () =
1334       let fname = Filename.concat db2.bdir2 "notes_of.txt" in
1335       match try Some (Secure.open_in fname) with [ Sys_error _ -> None ] with
1336       [ Some ic ->
1337           let r = input_line ic in
1338           do { close_in ic; r }
1339       | None -> "" ];
1340     base_notes_dir () = Filename.concat "base_d" "notes_d";
1341     base_wiznotes_dir () = Filename.concat "base_d" "wiznotes_d";
1342     nobtit conf p = C_base.nobtit self conf p;
1343     p_first_name p = C_base.p_first_name self p;
1344     p_surname p = C_base.p_surname self p;
1345     date_of_last_change () =
1346       let s =
1347         let bdir = db2.bdir2 in
1348         try Unix.stat (Filename.concat bdir "patches") with
1349         [ Unix.Unix_error _ _ _ -> Unix.stat bdir ]
1350       in
1351       s.Unix.st_mtime;
1352     apply_base1 f = invalid_arg "apply_base1";
1353     apply_base2 f = f db2}
1354;
1355
1356(* Database - user functions *)
1357
1358value open_base bname =
1359  let bname =
1360    if Filename.check_suffix bname ".gwb" then bname else bname ^ ".gwb"
1361  in
1362  if Sys.file_exists (Filename.concat bname "base_d") then
1363    base2 (base_of_base2 bname)
1364  else base1 (Database.opendb bname)
1365;
1366
1367value close_base b = b.close_base ();
1368value empty_person b = b.empty_person;
1369value person_of_gen_person b = b.person_of_gen_person;
1370value family_of_gen_family b = b.family_of_gen_family;
1371value poi b = b.poi;
1372value foi b = b.foi;
1373value sou b = b.sou;
1374value nb_of_persons b = b.nb_of_persons ();
1375value nb_of_families b = b.nb_of_families ();
1376value patch_person b = b.patch_person;
1377value patch_ascend b = b.patch_ascend;
1378value patch_union b = b.patch_union;
1379value patch_family b = b.patch_family;
1380value patch_descend b = b.patch_descend;
1381value patch_couple b = b.patch_couple;
1382value patch_name b = b.patch_name;
1383value patch_key b = b.patch_key;
1384value delete_key b = b.delete_key;
1385value insert_string b = b.insert_string;
1386value commit_patches b = b.commit_patches ();
1387value commit_notes b = b.commit_notes;
1388value is_patched_person b = b.is_patched_person;
1389value patched_ascends b = b.patched_ascends ();
1390value delete_family b = b.delete_family;
1391value person_of_key b = b.person_of_key;
1392value persons_of_name b = b.persons_of_name;
1393value persons_of_first_name b = b.persons_of_first_name ();
1394value persons_of_surname b = b.persons_of_surname ();
1395value base_visible_get b = b.base_visible_get;
1396value base_visible_write b = b.base_visible_write ();
1397value base_particles b = b.base_particles ();
1398value base_strings_of_first_name b = b.base_strings_of_first_name;
1399value base_strings_of_surname b = b.base_strings_of_surname;
1400value load_ascends_array b = b.load_ascends_array ();
1401value load_unions_array b = b.load_unions_array ();
1402value load_couples_array b = b.load_couples_array ();
1403value load_descends_array b = b.load_descends_array ();
1404value load_strings_array b = b.load_strings_array ();
1405value persons_array b = b.persons_array ();
1406value ascends_array b = b.ascends_array ();
1407value base_notes_read b = b.base_notes_read;
1408value base_notes_read_first_line b = b.base_notes_read_first_line;
1409value base_notes_are_empty b = b.base_notes_are_empty;
1410value base_notes_origin_file b = b.base_notes_origin_file ();
1411value base_notes_dir b = b.base_notes_dir ();
1412value base_wiznotes_dir b = b.base_wiznotes_dir ();
1413value nobtit b = b.nobtit;
1414value p_first_name b = b.p_first_name;
1415value p_surname b = b.p_surname;
1416value date_of_last_change b = b.date_of_last_change ();
1417value base_of_base1 = base1;
1418value apply_base1 b = b.apply_base1;
1419value apply_base2 b = b.apply_base2;
1420
1421value husbands base gp =
1422  let p = poi base gp.key_index in
1423  List.map
1424    (fun ifam ->
1425       let fam = foi base ifam in
1426       let husband = poi base (get_father fam) in
1427       let husband_surname = p_surname base husband in
1428       let husband_surnames_aliases =
1429         List.map (sou base) (get_surnames_aliases husband)
1430       in
1431       (husband_surname, husband_surnames_aliases))
1432    (Array.to_list (get_family p))
1433;
1434
1435value father_titles_places base p nobtit =
1436  match get_parents (poi base p.key_index) with
1437  [ Some ifam ->
1438      let fam = foi base ifam in
1439      let fath = poi base (get_father fam) in
1440      List.map (fun t -> sou base t.t_place) (nobtit fath)
1441  | None -> [] ]
1442;
1443
1444value gen_gen_person_misc_names base p nobtit nobtit_fun =
1445  let sou = sou base in
1446  Futil.gen_person_misc_names (sou p.first_name) (sou p.surname)
1447    (sou p.public_name) (List.map sou p.qualifiers) (List.map sou p.aliases)
1448    (List.map sou p.first_names_aliases) (List.map sou p.surnames_aliases)
1449    (List.map (Futil.map_title_strings sou) nobtit)
1450    (if p.sex = Female then husbands base p else [])
1451    (father_titles_places base p nobtit_fun)
1452;
1453
1454value gen_person_misc_names base p nobtit =
1455  gen_gen_person_misc_names base p (nobtit p)
1456    (fun p -> nobtit (gen_person_of_person p))
1457;
1458
1459value person_misc_names base p nobtit =
1460  gen_gen_person_misc_names base (gen_person_of_person p) (nobtit p) nobtit
1461;
1462