108 lines
3.4 KiB
OCaml
108 lines
3.4 KiB
OCaml
open Def
|
|
open Gwdb
|
|
|
|
type 'a event_name =
|
|
| Pevent of 'a gen_pers_event_name
|
|
| Fevent of 'a gen_fam_event_name
|
|
|
|
(*
|
|
On ignore les événements personnalisés.
|
|
Dans l'ordre de priorité :
|
|
birth, baptism, ..., death, funeral, burial/cremation.
|
|
Pour les évènements familiaux, cet ordre est envisageable :
|
|
engage, PACS, marriage bann, marriage contract, marriage, ...,
|
|
separate, divorce
|
|
*)
|
|
let compare_event_name name1 name2 =
|
|
match (name1, name2) with
|
|
| Pevent Epers_Birth, _ -> -1
|
|
| _, Pevent Epers_Birth -> 1
|
|
| ( Pevent Epers_Baptism,
|
|
Pevent (Epers_Death | Epers_Funeral | Epers_Burial | Epers_Cremation) ) ->
|
|
-1
|
|
| ( Pevent (Epers_Death | Epers_Funeral | Epers_Burial | Epers_Cremation),
|
|
Pevent Epers_Baptism ) ->
|
|
1
|
|
| Pevent Epers_Cremation, Pevent Epers_Burial -> -1
|
|
| Pevent (Epers_Burial | Epers_Cremation), _ -> 1
|
|
| _, Pevent (Epers_Burial | Epers_Cremation) -> -1
|
|
| Pevent Epers_Funeral, _ -> 1
|
|
| _, Pevent Epers_Funeral -> -1
|
|
| Pevent Epers_Death, _ -> 1
|
|
| _, Pevent Epers_Death -> -1
|
|
| _ -> 0
|
|
(*TODO Fevent??*)
|
|
|
|
let compare get_name get_date e1 e2 =
|
|
match Date.cdate_to_dmy_opt (get_date e1) with
|
|
| None -> compare_event_name (get_name e1) (get_name e2)
|
|
| Some d1 -> (
|
|
match Date.cdate_to_dmy_opt (get_date e2) with
|
|
| None -> compare_event_name (get_name e1) (get_name e2)
|
|
| Some d2 -> (
|
|
match Date.compare_dmy_opt ~strict:false d1 d2 with
|
|
| Some 0 | None -> compare_event_name (get_name e1) (get_name e2)
|
|
| Some x -> x))
|
|
|
|
let sort_events get_name get_date events =
|
|
List.stable_sort (fun e1 e2 -> compare get_name get_date e1 e2) events
|
|
|
|
type 'a event_item =
|
|
'a event_name
|
|
* cdate
|
|
* istr
|
|
* istr
|
|
* istr
|
|
* (iper * witness_kind) array
|
|
* iper option
|
|
|
|
let events conf base p =
|
|
if not (Util.authorized_age conf base p) then []
|
|
else
|
|
let pevents =
|
|
List.fold_right
|
|
(fun evt events ->
|
|
let name = Pevent evt.epers_name in
|
|
let date = evt.epers_date in
|
|
let place = evt.epers_place in
|
|
let note = evt.epers_note in
|
|
let src = evt.epers_src in
|
|
let wl = evt.epers_witnesses in
|
|
let x = (name, date, place, note, src, wl, None) in
|
|
x :: events)
|
|
(get_pevents p) []
|
|
in
|
|
let fevents =
|
|
Array.fold_right
|
|
(fun ifam fevents ->
|
|
let fam = foi base ifam in
|
|
let isp = Gutil.spouse (get_iper p) fam in
|
|
let m_auth =
|
|
Util.authorized_age conf base (Util.pget conf base isp)
|
|
in
|
|
let fam_fevents =
|
|
if m_auth then
|
|
List.fold_right
|
|
(fun evt fam_fevents ->
|
|
let name = Fevent evt.efam_name in
|
|
let date = evt.efam_date in
|
|
let place = evt.efam_place in
|
|
let note = evt.efam_note in
|
|
let src = evt.efam_src in
|
|
let wl = evt.efam_witnesses in
|
|
let x = (name, date, place, note, src, wl, Some isp) in
|
|
x :: fam_fevents)
|
|
(get_fevents fam) []
|
|
else []
|
|
in
|
|
fam_fevents @ fevents)
|
|
(get_family p) []
|
|
in
|
|
pevents @ fevents
|
|
|
|
let sorted_events conf base p =
|
|
let unsorted_events = events conf base p in
|
|
let get_name (n, _, _, _, _, _, _) = n in
|
|
let get_date (_, date, _, _, _, _, _) = date in
|
|
sort_events get_name get_date unsorted_events
|