Uzurka/Geneweb
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial comit - Clone

Browse Source
This commit is contained in:
Uzurka
2024-03-05 22:01:20 +01:00
commit 385cf8e5aa
727 changed files with 164567 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
lib/def/adef.ml Normal file
View File

@@ -0,0 +1,79 @@
(* $Id: adef.ml,v 5.6 2007-02-21 18:14:01 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
type fix = int
let float_of_fix x = float x /. 1000000.0
let fix_of_float x = truncate ((x *. 1000000.0) +. 0.5)
external fix : int -> fix = "%identity"
external fix_repr : fix -> int = "%identity"
let no_consang = fix (-1)
type date = Dgreg of dmy * calendar | Dtext of string
and calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = { day : int; month : int; year : int; prec : precision; delta : int }
and dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
and precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
| YearInt of dmy2
type cdate =
| Cgregorian of int
| Cjulian of int
| Cfrench of int
| Chebrew of int
| Ctext of string
| Cdate of date
| Cnone
type 'person gen_couple = { father : 'person; mother : 'person }
and 'person gen_parents = { parent : 'person array }
let father cpl =
if Obj.size (Obj.repr cpl) = 2 then cpl.father else (Obj.magic cpl).parent.(0)
let mother cpl =
if Obj.size (Obj.repr cpl) = 2 then cpl.mother else (Obj.magic cpl).parent.(1)
let couple father mother = { father; mother }
let parent parent = { father = parent.(0); mother = parent.(1) }
let parent_array cpl =
if Obj.size (Obj.repr cpl) = 2 then [| cpl.father; cpl.mother |]
else (Obj.magic cpl).parent
let multi_couple father mother : 'person gen_couple =
Obj.magic { parent = [| father; mother |] }
let multi_parent parent : 'person gen_couple = Obj.magic { parent }
type 'a astring = string
type safe_string = [ `encoded | `escaped | `safe ] astring
type escaped_string = [ `encoded | `escaped ] astring
type encoded_string = [ `encoded ] astring
let ( ^^^ ) : 'a astring -> 'a astring -> 'a astring =
fun (a : 'a astring) (b : 'a astring) : 'a astring -> a ^ b
let ( ^>^ ) : 'a astring -> string -> 'a astring =
fun (a : 'a astring) (b : string) : 'a astring -> a ^ b
let ( ^<^ ) : string -> 'a astring -> 'a astring =
fun (a : string) (b : 'a astring) : 'a astring -> a ^ b
let ( <^> ) : 'a astring -> 'a astring -> bool = ( <> )
external safe : string -> safe_string = "%identity"
external escaped : string -> escaped_string = "%identity"
external encoded : string -> encoded_string = "%identity"
external as_string : 'a astring -> string = "%identity"
let safe_fn = ( @@ )

92
lib/def/adef.mli Normal file
View File

@@ -0,0 +1,92 @@
(* $Id: adef.mli,v 5.6 2007-02-21 18:14:01 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)
type fix
(** Consanguinity rate *)
val float_of_fix : fix -> float
(** Returns float coefficient of consanguinity rate *)
val fix_of_float : float -> fix
(** Returns consanguinity rate from its float coefficient *)
external fix : int -> fix = "%identity"
(** [fix] from int *)
external fix_repr : fix -> int = "%identity"
(** [fix] to int *)
val no_consang : fix
(** No consanguinity *)
(** Date data type that can be either concrete date associated to a calendar or a textual form of the date. *)
type date = Dgreg of dmy * calendar | Dtext of string
(** Supported calendars *)
and calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = { day : int; month : int; year : int; prec : precision; delta : int }
(** Concrete date with precision. *)
and dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
(** Concrete date without precision. *)
(** Precision attached to the concrete date. *)
and precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
| YearInt of dmy2
(** Compressed date *)
type cdate =
| Cgregorian of int
| Cjulian of int
| Cfrench of int
| Chebrew of int
| Ctext of string
| Cdate of date
| Cnone
type 'person gen_couple
(** Polymorphic type to represent a family's couple.
Couple consists of the father and of the mother. *)
val father : 'a gen_couple -> 'a
(** Get father from couple *)
val mother : 'a gen_couple -> 'a
(** Get mother from couple *)
val couple : 'a -> 'a -> 'a gen_couple
(** [couple f m] creates a couple from father [f] and mother [m] *)
val parent : 'a array -> 'a gen_couple
(** Create [gen_couple] from array. First element of array should be father, second - mother *)
val parent_array : 'a gen_couple -> 'a array
(** Returns array from [gen_couple]. First element of array is father, second - mother *)
val multi_couple : 'a -> 'a -> 'a gen_couple
(** @deprecated Use [couple] instead *)
val multi_parent : 'a array -> 'a gen_couple
(** @deprecated Use [parent] instead *)
type +'a astring = private string
type safe_string = [ `encoded | `escaped | `safe ] astring
type escaped_string = [ `encoded | `escaped ] astring
type encoded_string = [ `encoded ] astring
val ( ^^^ ) : 'a astring -> 'a astring -> 'a astring
val ( ^>^ ) : 'a astring -> string -> 'a astring
val ( ^<^ ) : string -> 'a astring -> 'a astring
val ( <^> ) : 'a astring -> 'a astring -> bool
val safe : string -> safe_string
val escaped : string -> escaped_string
val encoded : string -> encoded_string
val as_string : 'a astring -> string
val safe_fn : (string -> string) -> 'a astring -> 'a astring

458
lib/def/def.ml Normal file
View File

@@ -0,0 +1,458 @@
(* Copyright (c) 1998-2007 INRIA *)
(** Http response status *)
type httpStatus =
| OK (* 200 *)
| Moved_Temporarily (* 302 *)
| Bad_Request (* 400 *)
| Unauthorized (* 401 *)
| Forbidden (* 403 *)
| Not_Found (* 404 *)
| Conflict (* 409 *)
| Internal_Server_Error (* 500 *)
| Service_Unavailable (* 503 *)
exception HttpExn of httpStatus * string
(* TODO OCaml 4.12 : use Either *)
(** Type that represents 2 possible choices *)
type ('a, 'b) choice = Left of 'a | Right of 'b
type cdate = Adef.cdate
(** Alias to [Adef.cdate] *)
(** Alias to [Adef.date] *)
type date = Adef.date =
| Dgreg of dmy * calendar
(* textual form of the date *)
| Dtext of string
(** Alias to [Adef.calendar] *)
and calendar = Adef.calendar = Dgregorian | Djulian | Dfrench | Dhebrew
and dmy = Adef.dmy = {
day : int;
month : int;
year : int;
prec : precision;
delta : int;
}
(** Alias to [Adef.dmy] *)
and dmy2 = Adef.dmy2 = { day2 : int; month2 : int; year2 : int; delta2 : int }
(** Alias to [Adef.dmy2] *)
(** Alias to [Adef.precision] *)
and precision = Adef.precision =
| Sure
| About
| Maybe
| Before
| After
| OrYear of dmy2
(* inteval *)
| YearInt of dmy2
(** Relation kind between couple in the family *)
type relation_kind =
| Married
| NotMarried
| Engaged
| NoSexesCheckNotMarried
| NoMention
| NoSexesCheckMarried
| MarriageBann
| MarriageContract
| MarriageLicense
| Pacs
| Residence
(** Divorce status *)
type divorce = NotDivorced | Divorced of cdate | Separated
(** Death reason *)
type death_reason = Killed | Murdered | Executed | Disappeared | Unspecified
(** Death status *)
type death =
| NotDead
| Death of death_reason * cdate
| DeadYoung
| DeadDontKnowWhen
| DontKnowIfDead
| OfCourseDead
(** Burial information *)
type burial = UnknownBurial | Buried of cdate | Cremated of cdate
(** Rights for access to the personal data *)
type access = IfTitles | Public | Private
(** Title name *)
type 'string gen_title_name = Tmain | Tname of 'string | Tnone
type 'string gen_title = {
t_name : 'string gen_title_name;
t_ident : 'string;
t_place : 'string;
t_date_start : cdate;
t_date_end : cdate;
t_nth : int;
}
(** Type that represents information about nobility title of a person *)
(** Witness kind for an event *)
type witness_kind =
| Witness
| Witness_GodParent
| Witness_CivilOfficer
| Witness_ReligiousOfficer
| Witness_Informant
| Witness_Attending
| Witness_Mentioned
| Witness_Other
(** Personal event name. *)
type 'string gen_pers_event_name =
| Epers_Birth
| Epers_Baptism
| Epers_Death
| Epers_Burial
| Epers_Cremation
| Epers_Accomplishment
| Epers_Acquisition
| Epers_Adhesion
| Epers_BaptismLDS
| Epers_BarMitzvah
| Epers_BatMitzvah
| Epers_Benediction
| Epers_ChangeName
| Epers_Circumcision
| Epers_Confirmation
| Epers_ConfirmationLDS
| Epers_Decoration
| Epers_DemobilisationMilitaire
| Epers_Diploma
| Epers_Distinction
| Epers_Dotation
| Epers_DotationLDS
| Epers_Education
| Epers_Election
| Epers_Emigration
| Epers_Excommunication
| Epers_FamilyLinkLDS
| Epers_FirstCommunion
| Epers_Funeral
| Epers_Graduate
| Epers_Hospitalisation
| Epers_Illness
| Epers_Immigration
| Epers_ListePassenger
| Epers_MilitaryDistinction
| Epers_MilitaryPromotion
| Epers_MilitaryService
| Epers_MobilisationMilitaire
| Epers_Naturalisation
| Epers_Occupation
| Epers_Ordination
| Epers_Property
| Epers_Recensement
| Epers_Residence
| Epers_Retired
| Epers_ScellentChildLDS
| Epers_ScellentParentLDS
| Epers_ScellentSpouseLDS
| Epers_VenteBien
| Epers_Will
| Epers_Name of 'string
type ('person, 'string) gen_pers_event = {
epers_name : 'string gen_pers_event_name;
epers_date : cdate;
epers_place : 'string;
epers_reason : 'string;
epers_note : 'string;
epers_src : 'string;
epers_witnesses : ('person * witness_kind) array;
}
(** Personal event information *)
(** Event name pertaining a family. *)
type 'string gen_fam_event_name =
| Efam_Marriage
| Efam_NoMarriage
| Efam_NoMention
| Efam_Engage
| Efam_Divorce
| Efam_Separated
| Efam_Annulation
| Efam_MarriageBann
| Efam_MarriageContract
| Efam_MarriageLicense
| Efam_PACS
| Efam_Residence
| Efam_Name of 'string
type ('person, 'string) gen_fam_event = {
efam_name : 'string gen_fam_event_name;
efam_date : cdate;
efam_place : 'string;
efam_reason : 'string;
efam_note : 'string;
efam_src : 'string;
efam_witnesses : ('person * witness_kind) array;
}
(** Event information pertaining a family. *)
(** Relation type with parent (if not native) *)
type relation_type =
| Adoption
| Recognition
| CandidateParent
| GodParent
| FosterParent
type ('person, 'string) gen_relation = {
r_type : relation_type;
r_fath : 'person option;
r_moth : 'person option;
r_sources : 'string;
}
(** Relation information with parents (if not native) *)
(** Sex of person *)
type sex = Male | Female | Neuter
type place = {
other : string;
town : string;
township : string;
canton : string;
district : string;
county : string;
region : string;
country : string;
}
(** Place information *)
type ('iper, 'person, 'string) gen_person = {
first_name : 'string;
surname : 'string;
occ : int;
image : 'string;
public_name : 'string;
qualifiers : 'string list;
aliases : 'string list;
first_names_aliases : 'string list;
surnames_aliases : 'string list;
titles : 'string gen_title list;
(* relations with not native parents *)
rparents : ('person, 'string) gen_relation list;
(* related persons like (father of witnessed family,
concerned person of witnessed event, adopted child, etc.) *)
related : 'person list;
occupation : 'string;
sex : sex;
access : access;
birth : cdate;
birth_place : 'string;
birth_note : 'string;
birth_src : 'string;
baptism : cdate;
baptism_place : 'string;
baptism_note : 'string;
baptism_src : 'string;
death : death;
death_place : 'string;
death_note : 'string;
death_src : 'string;
burial : burial;
burial_place : 'string;
burial_note : 'string;
burial_src : 'string;
pevents : ('person, 'string) gen_pers_event list;
notes : 'string;
psources : 'string;
key_index : 'iper;
}
(** Polymorphic type describing information about person. *)
type 'family gen_ascend = { parents : 'family option; consang : Adef.fix }
(** Person's ascendants (family where he is a children) with its consangunity rate
(equal to relationship betwen his parents). *)
(* Person's families to which he belongs as parent (union of families) *)
type 'family gen_union = { family : 'family array }
type 'person gen_descend = { children : 'person array }
(** Children of the family *)
type ('person, 'ifam, 'string) gen_family = {
marriage : cdate;
marriage_place : 'string;
marriage_note : 'string;
marriage_src : 'string;
witnesses : 'person array;
relation : relation_kind;
divorce : divorce;
fevents : ('person, 'string) gen_fam_event list;
comment : 'string;
origin_file : 'string; (* .gw filename where family is defined *)
fsources : 'string;
fam_index : 'ifam;
}
(** Polymorphic type describing information about family. *)
type 'person gen_couple = 'person Adef.gen_couple
(** Alias to [Adef.gen_couple] *)
(** Database errors describing bad specification of the person *)
type 'person error =
| AlreadyDefined of 'person
| OwnAncestor of 'person (** Person is his own ancestor *)
| BadSexOfMarriedPerson of 'person
(** Database warnings attached to the specification of the person, family, relation, etc. *)
type ('iper, 'person, 'family, 'descend, 'title, 'pevent, 'fevent) warning =
| BigAgeBetweenSpouses of
'person
* 'person
* dmy (* Age differece between couples is greater then 50 years *)
| BirthAfterDeath of 'person (** Person is born after his death *)
| IncoherentSex of 'person * int * int (** Incoherent sex of person *)
| ChangedOrderOfChildren of 'family * 'descend * 'iper array * 'iper array
(** Children order has been modified *)
| ChangedOrderOfMarriages of 'person * 'family array * 'family array
(** Person's marriages order has been modified *)
| ChangedOrderOfFamilyEvents of 'family * 'fevent list * 'fevent list
(** Family's events order has been modified *)
| ChangedOrderOfPersonEvents of 'person * 'pevent list * 'pevent list
(** Person's events order has been modified *)
| ChildrenNotInOrder of 'family * 'descend * 'person * 'person
(** Children aren't ordered *)
| CloseChildren of 'family * 'person * 'person
(** Age difference between two child is less then 7 month (except for twins) *)
| DeadOld of 'person * dmy
(** Dead old (at the age older then 109 after 1900 year and older then 100 before) *)
| DeadTooEarlyToBeFather of 'person * 'person
(** Children is born in more then 1 year after his father's death *)
| DistantChildren of 'family * 'person * 'person
(** Age gap between two of siblings greater then 50 years *)
| FEventOrder of 'person * 'fevent * 'fevent
(** Familial events haven't been ordered correctly *)
| FWitnessEventAfterDeath of 'person * 'fevent * 'family
(** Witness is dead before familial event date *)
| FWitnessEventBeforeBirth of 'person * 'fevent * 'family
(** Witness is born after familial event date *)
| IncoherentAncestorDate of 'person * 'person
(** Ancestor is born after person's birth *)
| MarriageDateAfterDeath of 'person (** Person is married after his death *)
| MarriageDateBeforeBirth of 'person
(** Person is married before his birth *)
| MotherDeadBeforeChildBirth of 'person * 'person
(** Children is born after his mother's death *)
| ParentBornAfterChild of 'person * 'person
(** Parent is born after one of his children *)
| ParentTooOld of 'person * dmy * 'person
(** Person became a parent at age older then 55 years for mother and 70 for father *)
| ParentTooYoung of 'person * dmy * 'person
(** Person became a parent at age younger then 11 years old *)
| PEventOrder of 'person * 'pevent * 'pevent
(** Personal events haven't been ordered correctly *)
| PossibleDuplicateFam of 'family * 'family
(** There is a possibility that two families are a duplicate of each other *)
| PossibleDuplicateFamHomonymous of 'family * 'family * 'person
(** There is a possibility that two families are a duplicate of each other (Homonymous spouse) *)
| PWitnessEventAfterDeath of 'person * 'pevent * 'person
(** Witness is dead before personal event date *)
| PWitnessEventBeforeBirth of 'person * 'pevent * 'person
(** Witness is born after personal event date *)
| TitleDatesError of 'person * 'title
(** Title's start date is after end date or person is born after title dates *)
| UndefinedSex of 'person (** Person has undefined sex (Neuter) *)
| YoungForMarriage of 'person * dmy * 'family
(** Person is married before he was 12 years old *)
| OldForMarriage of 'person * dmy * 'family
(** Person is married after he was 100 years old *)
(** Missing sources warning *)
type ('person, 'descend, 'title) misc = MissingSources
(** Database note/page reading mode *)
type rn_mode =
| RnAll (** Read all content *)
| Rn1Ln (** Read first line *)
| RnDeg (** If file isn't empty returns a space *)
type base_notes = {
(* read content of the page with giving mode.
Page "" represent database note *)
nread : string -> rn_mode -> string; (* origin .gw filename *)
norigin_file : string; (* returns list of extended pages *)
efiles : unit -> string list;
}
(** Database note/page explorer structure *)
(** Update modification used for history tracking *)
type ('iper, 'person, 'family, 'string) base_changed =
| U_Add_person of ('iper, 'person, 'string) gen_person
| U_Modify_person of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
| U_Delete_person of ('iper, 'person, 'string) gen_person
| U_Merge_person of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
| U_Send_image of ('iper, 'person, 'string) gen_person
| U_Delete_image of ('iper, 'person, 'string) gen_person
| U_Add_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Modify_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
| U_Delete_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Invert_family of ('iper, 'person, 'string) gen_person * 'family
| U_Merge_family of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
* ('person, 'family, 'string) gen_family
| U_Change_children_name of
('iper, 'person, 'string) gen_person
* ((string * string * int * 'person) * (string * string * int * 'person))
list
| U_Add_parent of
('iper, 'person, 'string) gen_person
* ('person, 'family, 'string) gen_family
| U_Kill_ancestors of ('iper, 'person, 'string) gen_person
(* Modification U_Multi used when multiple persons are modified successively. Separation with U_Modify_person is necessary to inform foreign notify_change script
about database change without creating process for every person. *)
| U_Multi of
('iper, 'person, 'string) gen_person
* ('iper, 'person, 'string) gen_person
* bool
| U_Notes of int option * string
(** TODOOCP : doc *)
module NLDB = struct
type ('a, 'b) page =
| PgInd of 'a
| PgFam of 'b
| PgNotes
| PgMisc of string
| PgWizard of string
type key = string * string * int
type ind = { lnTxt : string option; lnPos : int }
type ('a, 'b) t = (('a, 'b) page * (string list * (key * ind) list)) list
end
let ( ^^^ ) = Adef.( ^^^ )
let ( ^>^ ) = Adef.( ^>^ )
let ( ^<^ ) = Adef.( ^<^ )

4
lib/def/dune Normal file
View File

@@ -0,0 +1,4 @@
(library
(name geneweb_def)
(public_name geneweb.def)
(wrapped false))