(* Copyright (c) 1998-2007 INRIA *)
open Config
open Def
open Util
open Gwdb
let get_wday conf = function
| Dgreg (({ prec = Sure; delta = 0 } as d), _) when d.day <> 0 && d.month <> 0
->
let jd = Calendar.sdn_of_gregorian d in
let wday =
let jd_today = Calendar.sdn_of_gregorian conf.today in
let x = conf.today_wd - jd_today + jd in
if x < 0 then 6 + ((x + 1) mod 7) else x mod 7
in
" (" ^ transl_nth conf "(week day)" wday ^ ")"
| _ -> ""
let death_symbol conf =
try List.assoc "death_symbol" conf.base_env with Not_found -> "†"
let code_date conf encoding d m y =
let apply_date_code = function
| 'd' -> string_of_int d
| 'm' -> transl_nth conf "(month)" (m - 1)
| 'y' -> string_of_int y
| c -> "%" ^ String.make 1 c
in
let rec loop i =
if i = String.length encoding then ""
else
let s, i =
match encoding.[i] with
| '%' when i + 1 < String.length encoding ->
let s = apply_date_code encoding.[i + 1] in
(s, i + 1)
| '[' -> (
try
(* code similar to Util.gen_decline *)
let len = String.length encoding in
let j = String.index_from encoding i ']' in
let k = String.index_from encoding i '|' in
if k < j && j + 2 < len && encoding.[j + 1] = '%' then
let s = apply_date_code encoding.[j + 2] in
let s1 =
if start_with_vowel conf s then
String.sub encoding (k + 1) (j - k - 1)
else String.sub encoding (i + 1) (k - i - 1)
in
(s1 ^ s, j + 2)
else (String.make 1 '[', i)
with Not_found -> (String.make 1 '[', i))
| c -> (String.make 1 c, i)
in
s ^ loop (i + 1)
in
loop 0
let code_dmy conf d =
let encoding =
let n =
if d.day = 1 then 0
else if d.day != 0 then 1
else if d.month != 0 then 2
else 3
in
transl_nth conf "(date)" n
in
code_date conf encoding d.day d.month d.year
let default_french_month =
let tab =
[|
"Vendemiaire";
"Brumaire";
"Frimaire";
"Nivose";
"Pluviose";
"Ventose";
"Germinal";
"Floreal";
"Prairial";
"Messidor";
"Thermidor";
"Fructidor";
"Extra";
|]
in
fun m -> tab.(m)
let default_hebrew_month =
let tab =
[|
"Tishri";
"Heshvan";
"Kislev";
"Tevet";
"Shevat";
"AdarI";
"AdarII";
"Nisan";
"Iyyar";
"Sivan";
"Tammuz";
"Av";
"Elul";
|]
in
fun m -> tab.(m)
let french_month conf m =
let r = transl_nth conf "(french revolution month)" m in
if r = "[(french revolution month)]" then "[" ^ default_french_month m ^ "]"
else r
let hebrew_month conf m =
let r = transl_nth conf "(hebrew month)" m in
if r = "[(hebrew month)]" then "[" ^ default_hebrew_month m ^ "]" else r
let code_french_year conf y =
transl_nth conf "year/month/day" 3
^ " "
^ if y >= 1 && y < 4000 then Mutil.roman_of_arabian y else string_of_int y
let code_french_date conf d m y =
let s =
if d = 0 then ""
else string_of_int d ^ if d = 1 then "er" else ""
in
let s =
if m = 0 then ""
else s ^ (if s = "" then "" else " ") ^ french_month conf (m - 1)
in
s ^ (if s = "" then "" else " ") ^ code_french_year conf y
let code_hebrew_date conf d m y =
let s = if d = 0 then "" else string_of_int d in
let s =
if m = 0 then ""
else s ^ (if s = "" then "" else " ") ^ hebrew_month conf (m - 1)
in
s ^ (if s = "" then "" else " ") ^ string_of_int y
let string_of_on_prec_dmy_aux conf sy sy2 d =
match d.prec with
| Sure ->
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
| About | Before | After ->
let s = sy in
if d.prec = About then transl_decline conf "about (date)" s
else if d.prec = Before then transl_decline conf "before (date)" s
else transl_decline conf "after (date)" s
| Maybe ->
let s =
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
in
transl_decline conf "possibly (date)" s
| OrYear d2 ->
let s =
if d.day = 0 && d.month = 0 then transl conf "in (year)" ^ " " ^ sy
else if d.day = 0 then transl_decline conf "in (month year)" sy
else transl_decline conf "on (day month year)" sy
in
let s2 =
if d2.day2 = 0 && d2.month2 = 0 then transl conf "in (year)" ^ " " ^ sy2
else if d2.day2 = 0 then transl_decline conf "in (month year)" sy2
else transl_decline conf "on (day month year)" sy2
in
s ^ " " ^ transl conf "or" ^ " " ^ Mutil.nominative s2
| YearInt d2 ->
let s =
if d.day = 0 && d.month = 0 then sy
else if d.day = 0 then sy
else transl_decline conf "on (day month year)" sy
in
let s2 =
if d2.day2 = 0 && d2.month2 = 0 then sy2
else if d2.day2 = 0 then sy2
else transl_decline conf "on (day month year)" sy2
in
transl conf "between (date)"
^ " " ^ s ^ " " ^ transl_nth conf "and" 0 ^ " " ^ Mutil.nominative s2
let replace_spaces_by_nbsp s =
let rec loop i len =
if i = String.length s then Buff.get len
else if s.[i] = ' ' then loop (i + 1) (Buff.mstore len " ")
else loop (i + 1) (Buff.store len s.[i])
in
loop 0 0
let string_of_on_prec_dmy conf sy sy2 d =
Adef.safe
@@
let r = string_of_on_prec_dmy_aux conf sy sy2 d in
replace_spaces_by_nbsp r
let string_of_on_french_dmy conf d =
let sy = code_french_date conf d.day d.month d.year in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_french_date conf d2.day2 d2.month2 d2.year2
| _ -> ""
in
string_of_on_prec_dmy conf sy sy2 d
let string_of_on_hebrew_dmy conf d =
let sy = code_hebrew_date conf d.day d.month d.year in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_hebrew_date conf d2.day2 d2.month2 d2.year2
| _ -> ""
in
string_of_on_prec_dmy conf sy sy2 d
let string_of_prec_dmy conf s s2 d =
Adef.safe
@@
match d.prec with
| Sure -> Mutil.nominative s
| About -> transl_decline conf "about (date)" s
| Before -> transl_decline conf "before (date)" s
| After -> transl_decline conf "after (date)" s
| Maybe -> transl_decline conf "possibly (date)" s
| OrYear _ -> s ^ " " ^ transl conf "or" ^ " " ^ Mutil.nominative s2
| YearInt _ ->
transl conf "between (date)"
^ " " ^ s ^ " " ^ transl_nth conf "and" 0 ^ " " ^ Mutil.nominative s2
let string_of_dmy_aux fn conf d =
let sy = code_dmy conf d in
let sy2 =
match d.prec with
| OrYear d2 | YearInt d2 -> code_dmy conf (Date.dmy_of_dmy2 d2)
| _ -> ""
in
fn conf sy sy2 d
let string_of_on_dmy conf d = string_of_dmy_aux string_of_on_prec_dmy conf d
let string_of_dmy conf d = string_of_dmy_aux string_of_prec_dmy conf d
(* ************************************************************************ *)
(* [Fonc] translate_dmy : config -> (string * string * string) ->
calendar -> bool -> (string * string * string) *)
(* ************************************************************************ *)
(** [Description] : Traduit en fonction du calendrier, le mois et/ou l'année
d'une date et renvoie le triplet conformément au format
de la date.
[Args] :
- conf : configuration de la base
- (fst, snd, trd) : la date au bon format
- cal : calendar
- short : booléen pour savoir si on affiche au format court, e.g.
VD/Vendémiaire
[Retour] : (string * string * string) : date traduite
[Rem] : Non exporté en clair hors de ce module. *)
let translate_dmy conf (fst, snd, trd) cal short =
let translate_month m =
match cal with
| Dfrench when m <> "" ->
if short then Util.short_f_month (int_of_string m)
else french_month conf (int_of_string m)
| Dhebrew when m <> "" ->
if short then
String.uppercase_ascii
(String.sub (hebrew_month conf (int_of_string m)) 0 2)
else hebrew_month conf (int_of_string m)
| _ -> m
in
let translate_year y =
match cal with
| Dfrench ->
let y1 = int_of_string y in
if y1 >= 1 && y1 < 4000 then Mutil.roman_of_arabian y1 else y
| _ -> y
in
match transl conf "!dates order" with
| "yymmdd" | "yyyymmdd" -> (translate_year fst, translate_month snd, trd)
| "mmddyyyy" -> (translate_month fst, snd, translate_year trd)
| _ -> (fst, translate_month snd, translate_year trd)
(** [decode_dmy conf dmy]
Returns a triplet corresponding to day/month/year, arranged in
the order defined by [!dates order] keyword in the lexicon.
Supported formats are: "dmyyyy" / "mmddyyyy" / "yyyymmdd" / "ddmmyyyy" and "ddmmyy".
NB: "yy" and "yyyy" variants will produce the same output ([string_of_int] without padding)
If the format is not supported "ddmmyyyy" is used.
*)
let decode_dmy conf d =
match transl conf "!dates order" with
| "dmyyyy" ->
(string_of_int d.day, string_of_int d.month, string_of_int d.year)
| "mmddyyyy" -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> ("", "", string_of_int year)
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
(m, "", string_of_int year)
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(m, d, string_of_int year))
| "yyyymmdd" | "yymmdd" -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> (string_of_int year, "", "")
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
(string_of_int year, m, "")
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(string_of_int year, m, d))
| "ddmmyyyy" | "ddmmyy" | _ -> (
(* Si le jour et/ou le mois n'est pas sur 2 caractères, *)
(* on rajoute les 0 nécessaires. *)
match (d.day, d.month, d.year) with
| 0, 0, year -> ("", "", string_of_int year)
| 0, month, year ->
let m = Printf.sprintf "%02d" month in
("", m, string_of_int year)
| day, month, year ->
let d = Printf.sprintf "%02d" day in
let m = Printf.sprintf "%02d" month in
(d, m, string_of_int year))
let gregorian_precision conf d =
if d.delta = 0 then string_of_dmy conf d
else
let d2 =
Calendar.gregorian_of_sdn d.prec (Calendar.sdn_of_gregorian d + d.delta)
in
Adef.safe
@@ transl conf "between (date)"
^ " "
^ (string_of_on_dmy conf d :> string)
^ " " ^ transl_nth conf "and" 0 ^ " "
^ (string_of_on_dmy conf d2 :> string)
let string_of_date_aux ?(link = true) ?(dmy = string_of_dmy)
?(sep = Adef.safe " ") conf =
let mk_link c d (s : Adef.safe_string) =
Adef.safe
@@ Printf.sprintf
{|%s|}
(commd conf :> string)
c d.year c d.month c d.day c
(s :> string)
in
function
| Dgreg (d, Dgregorian) ->
let s = dmy conf d in
if link && d.day > 0 then mk_link 'g' d s else s
| Dgreg (d, Djulian) ->
let cal_prec =
if d.year < 1582 then Adef.safe ""
else " (" ^<^ gregorian_precision conf d ^>^ ")"
in
let d1 = Calendar.julian_of_gregorian d in
let year_prec =
if
(d1.month > 0 && d1.month < 3)
|| (d1.month = 3 && d1.day > 0 && d1.day < 25)
then Printf.sprintf " (%d/%d)" (d1.year - 1) (d1.year mod 10)
else ""
in
let s =
dmy conf d1 ^^^ year_prec ^<^ sep
^^^ transl_nth conf "gregorian/julian/french/hebrew" 1
^<^ cal_prec
in
if link && d1.day > 0 then mk_link 'j' d1 s else s
| Dgreg (d, Dfrench) -> (
let d1 = Calendar.french_of_gregorian d in
let s = string_of_on_french_dmy conf d1 in
let s = if link && d1.day > 0 then mk_link 'f' d1 s else s in
match d.prec with
| Sure | About | Before | After | Maybe ->
s ^^^ sep ^^^ " (" ^<^ gregorian_precision conf d ^>^ ")"
| OrYear _ | YearInt _ -> s)
| Dgreg (d, Dhebrew) -> (
let d1 = Calendar.hebrew_of_gregorian d in
let s = string_of_on_hebrew_dmy conf d1 in
match d.prec with
| Sure | About | Before | After | Maybe ->
s ^^^ sep ^^^ " (" ^<^ gregorian_precision conf d ^>^ ")"
| OrYear _ | YearInt _ -> s)
| Dtext t -> "(" ^<^ (Util.escape_html t :> Adef.safe_string) ^>^ ")"
let string_of_ondate ?link conf d =
(string_of_date_aux ?link ~dmy:string_of_on_dmy conf d :> string)
|> Util.translate_eval |> Adef.safe
let string_of_date conf = function
| Dgreg (d, _) -> string_of_dmy conf d
| Dtext t -> (Util.escape_html t :> Adef.safe_string)
let string_slash_of_date conf date =
let rec slashify_dmy (fst, snd, trd) d =
let code fst snd trd =
List.fold_right
(fun s accu -> if s <> "" then s ^ "/" ^ accu else accu)
[ fst; snd ] trd
in
match d.prec with
| OrYear d2 ->
let sy = code fst snd trd in
let d2 = Date.dmy_of_dmy2 d2 in
let sy2 = slashify_dmy (decode_dmy conf d2) d2 in
sy ^ " " ^ transl conf "or" ^ " " ^ sy2
| YearInt d2 ->
let sy = code fst snd trd in
let d2 = Date.dmy_of_dmy2 d2 in
let sy2 = slashify_dmy (decode_dmy conf d2) d2 in
transl conf "between (date)"
^ " " ^ sy ^ " " ^ transl_nth conf "and" 0 ^ " " ^ sy2
| _ ->
let sy = code fst snd trd in
(string_of_prec_dmy conf sy "" d :> string)
in
match date with
| Dtext t -> (Util.escape_html t :> Adef.safe_string)
| Dgreg (d, cal) -> (
Adef.safe
@@
match cal with
| Dgregorian -> slashify_dmy (decode_dmy conf d) d
| Djulian ->
let d1 = Calendar.julian_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Djulian true) d1
^ " ("
^ transl_nth conf "gregorian/julian/french/hebrew" 1
^ ")"
| Dfrench ->
let d1 = Calendar.french_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Dfrench true) d1
| Dhebrew ->
let d1 = Calendar.french_of_gregorian d in
slashify_dmy (translate_dmy conf (decode_dmy conf d1) Dhebrew true) d1
^ " ("
^ transl_nth conf "gregorian/julian/french/hebrew" 3
^ ")")
let string_of_age conf a =
Adef.safe
@@
match a with
| { day = 0; month = 0; year = y } ->
if y > 1 then string_of_int y ^ " " ^ transl conf "years old"
else if y = 1 then transl conf "one year old"
else transl conf "birth"
| { day = 0; month = m; year = y } ->
if y >= 2 then string_of_int y ^ " " ^ transl conf "years old"
else if y > 0 || m > 1 then
string_of_int ((y * 12) + m) ^ " " ^ transl conf "months old"
else if m = 1 then transl conf "one month old"
else transl conf "less than one month old"
| { day = d; month = m; year = y } ->
if y >= 2 then string_of_int y ^ " " ^ transl conf "years old"
else if y > 0 || m > 1 then
string_of_int ((y * 12) + m) ^ " " ^ transl conf "months old"
else if m = 1 then transl conf "one month old"
else if d >= 2 then string_of_int d ^ " " ^ transl conf "days old"
else if d = 1 then transl conf "one day old"
else "0"
(* ************************************************************************ *)
(* [Fonc] prec_text : config -> Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie la précision d'une date.
[Args] :
- conf : configuration de la base
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let prec_text conf d =
match d.prec with
| About -> (
(* On utilise le dictionnaire pour être sur *)
(* que ce soit compréhensible de tous. *)
match transl conf "about (short date)" with "ca" -> "ca " | s -> s)
| Maybe -> "?"
| Before -> "<"
| After -> ">"
| OrYear _ -> "|"
| YearInt _ -> ".."
| Sure -> ""
(* ************************************************************************ *)
(* [Fonc] month_text : Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie le mois d'une date.
[Args] :
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let month_text d = if d.month = 0 then "" else string_of_int d.month
(* ************************************************************************ *)
(* [Fonc] year_text : Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie l'année d'une date.
[Args] :
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let year_text d =
match d.prec with
| OrYear d2 when d.year <> d2.year2 ->
string_of_int d.year ^ "/" ^ string_of_int d2.year2
| YearInt d2 when d.year <> d2.year2 ->
string_of_int d.year ^ ".." ^ string_of_int d2.year2
| _ -> string_of_int d.year
(* ************************************************************************ *)
(* [Fonc] prec_year_text : config -> Def.dmy -> string *)
(* ************************************************************************ *)
(** [Description] : Renvoie la précision d'une date et l'année de la date.
[Args] :
- conf : configuration de la base
- d : Def.dmy
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let prec_year_text conf d =
let s =
match d.prec with
| About -> (
(* On utilise le dictionnaire pour être sur *)
(* que ce soit compréhensible de tous. *)
match transl conf "about (short date)" with "ca" -> "ca " | s -> s)
| Maybe -> "?"
| Before -> "/"
| _ -> ""
in
let s = s ^ year_text d in
match d.prec with After -> s ^ "/" | _ -> s
(* ********************************************************************** *)
(* [Fonc] short_dates_text : config -> base -> person -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie la concatenation de l'année de naissance et
l'année de décès (si trouvée par get_birth_death_date). La précision
de la date est ajoutée pour chaque année.
L'affichage est le suivant :
* 1700-1780 (date naissance - date décès)
* 1700- (naissance - décédé)
* 1700 (naissance - vivant)
* †1780 (pas date naissance - date décès)
* † (pas date naissance - décédé)
[Args] :
- conf : configuration de la base
- base : base de donnée
- p : person
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_dates_text conf base p =
Adef.safe
@@
if authorized_age conf base p then
let birth_date, death_date, _ = Gutil.get_birth_death_date p in
let s =
match (birth_date, death_date) with
| Some (Dgreg (b, _)), Some (Dgreg (d, _)) ->
prec_year_text conf b ^ "-" ^ prec_year_text conf d
| Some (Dgreg (b, _)), _ -> (
(* La personne peut être décédée mais ne pas avoir de date. *)
match get_death p with
| Death (_, _) | DeadDontKnowWhen | DeadYoung ->
prec_year_text conf b ^ "-"
| _ -> prec_year_text conf b)
| _, Some (Dgreg (d, _)) -> death_symbol conf ^ prec_year_text conf d
| _, _ -> (
(* La personne peut être décédée mais ne pas avoir de date. *)
match get_death p with
| Death (_, _) | DeadDontKnowWhen | DeadYoung -> death_symbol conf
| _ -> "")
in
if s <> "" then " " ^ s ^ "" else s
else ""
(* ********************************************************************** *)
(* [Fonc] short_marriage_date_text :
config -> base -> person -> person -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie l'année de la date de mariage ansi que la
précision de la date.
[Args] :
- conf : configuration de la base
- base : base de donnée
- p1 : conjoint 1
- p2 : conjoint 2
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_marriage_date_text conf base fam p1 p2 =
Adef.safe
@@
if authorized_age conf base p1 && authorized_age conf base p2 then
match Date.cdate_to_dmy_opt (get_marriage fam) with
| Some d ->
"" ^ prec_year_text conf d ^ ""
| None -> ""
else ""
(* ********************************************************************** *)
(* [Fonc] short_family_date_text :
config -> base -> bool -> family -> string *)
(* ********************************************************************** *)
(** [Description] : Renvoie l'année marriage - séparation
ou uniquement l'année de la séparation.
[Args] :
- conf : configuration de la base
- base : base de donnée
- bool : si faux, uniquement dates de la séparation
- family : famille
[Retour] : string
[Rem] : Exporté en clair hors de ce module. *)
let short_family_dates_text conf _base marr_sep fam =
let marr_dates_aux =
match Date.cdate_to_dmy_opt (Gwdb.get_marriage fam) with
| Some dmy -> Some (prec_year_text conf dmy)
| None -> Some ""
in
let sep_dates_aux =
match
List.find_opt
(fun e ->
e.efam_name = Efam_Divorce
|| e.efam_name = Efam_Annulation
|| e.efam_name = Efam_Separated)
(Gwdb.get_fevents fam)
with
| None -> None
| Some e -> (
match Date.cdate_to_dmy_opt e.efam_date with
| None -> Some ""
| Some dmy -> Some (prec_year_text conf dmy))
in
Adef.safe
@@
if marr_sep then
match (marr_dates_aux, sep_dates_aux) with
| Some m, Some s -> m ^ "-" ^ s
| Some m, None -> m
| None, _ -> ""
else Option.value ~default:"" sep_dates_aux
(* For public interfce, force [string_of_prec_dmy] args to be safe strings *)
let string_of_prec_dmy conf s s2 d =
let s = (s : Adef.safe_string :> string) in
let s2 = (s2 : Adef.safe_string :> string) in
string_of_prec_dmy conf s s2 d