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