604 lines
22 KiB
OCaml
604 lines
22 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
|
|
type date_event = DeBirth | DeDeath of death_reason
|
|
|
|
let print_age conf a_ref a =
|
|
Output.print_sstring conf " <em>";
|
|
Output.print_sstring conf (string_of_int a);
|
|
Output.print_sstring conf "</em>";
|
|
Output.print_sstring conf ", ";
|
|
match a_ref - a with
|
|
| 0 -> Output.print_sstring conf (transl conf "birth")
|
|
| 1 -> Output.print_sstring conf (transl conf "one year old")
|
|
| n ->
|
|
Output.print_sstring conf (string_of_int n);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "years old")
|
|
|
|
let print_anniversary_day conf base dead_people liste =
|
|
let a_ref = conf.today.year in
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun (p, a, date_event, txt_of) ->
|
|
let is = index_of_sex (get_sex p) in
|
|
Output.print_sstring conf "<li>";
|
|
Output.print_string conf (txt_of conf base p);
|
|
if not dead_people then print_age conf a_ref a
|
|
else (
|
|
Output.print_sstring conf ", <em>";
|
|
(Output.print_sstring conf
|
|
@@
|
|
match date_event with
|
|
| DeBirth -> transl_nth conf "born" is
|
|
| DeDeath Unspecified -> transl_nth conf "died" is
|
|
| DeDeath Killed -> transl_nth conf "killed (in action)" is
|
|
| DeDeath Murdered -> transl_nth conf "murdered" is
|
|
| DeDeath Executed -> transl_nth conf "executed (legally killed)" is
|
|
| DeDeath Disappeared -> transl_nth conf "disappeared" is);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "in (year)");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (string_of_int a);
|
|
Output.print_sstring conf "</em>");
|
|
Output.print_sstring conf "</li>")
|
|
liste;
|
|
Output.print_sstring conf "</ul>"
|
|
|
|
let gen_print conf base mois f_scan dead_people =
|
|
let tab = Array.make 31 [] in
|
|
let title _ =
|
|
let lab =
|
|
if dead_people then transl conf "anniversaries"
|
|
else transl conf "birthdays"
|
|
in
|
|
Output.printf conf "%s %s" (Utf8.capitalize_fst lab)
|
|
(Util.translate_eval (transl_nth conf "(month)" (mois - 1)))
|
|
in
|
|
(try
|
|
while true do
|
|
let p, txt_of = f_scan () in
|
|
if not dead_people then
|
|
match (Date.cdate_to_dmy_opt (get_birth p), get_death p) with
|
|
| Some d, (NotDead | DontKnowIfDead) ->
|
|
if
|
|
d.prec = Sure && d.day <> 0 && d.month <> 0 && d.month = mois
|
|
&& d.delta = 0
|
|
then
|
|
if authorized_age conf base p then
|
|
let j = d.day in
|
|
tab.(pred j) <- (p, d.year, DeBirth, txt_of) :: tab.(pred j)
|
|
| _ -> ()
|
|
else
|
|
match get_death p with
|
|
| NotDead | DontKnowIfDead -> ()
|
|
| Death _ | DeadYoung | DeadDontKnowWhen | OfCourseDead -> (
|
|
(match Date.cdate_to_dmy_opt (get_birth p) with
|
|
| None -> ()
|
|
| Some dt ->
|
|
if
|
|
dt.prec = Sure && dt.day <> 0 && dt.month <> 0
|
|
&& dt.month = mois && dt.delta = 0
|
|
then
|
|
if authorized_age conf base p then
|
|
let j = dt.day in
|
|
tab.(pred j) <-
|
|
(p, dt.year, DeBirth, txt_of) :: tab.(pred j));
|
|
match get_death p with
|
|
| NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead
|
|
| OfCourseDead ->
|
|
()
|
|
| Death (dr, d) -> (
|
|
match Date.cdate_to_dmy_opt d with
|
|
| None -> ()
|
|
| Some dt ->
|
|
if
|
|
dt.prec = Sure && dt.day <> 0 && dt.month <> 0
|
|
&& dt.month = mois && dt.delta = 0
|
|
then
|
|
if authorized_age conf base p then
|
|
let j = dt.day in
|
|
let a = dt.year in
|
|
tab.(pred j) <-
|
|
(p, a, DeDeath dr, txt_of) :: tab.(pred j)))
|
|
done
|
|
with Not_found -> ());
|
|
Hutil.header conf title;
|
|
if Array.for_all (( = ) []) tab then (
|
|
Output.print_sstring conf "<p>\n";
|
|
Output.printf conf "%s.\n"
|
|
(Utf8.capitalize_fst (transl conf "no anniversary"));
|
|
Output.print_sstring conf "</p>\n");
|
|
Output.print_sstring conf "<ul>\n";
|
|
for j = 1 to 31 do
|
|
if tab.(pred j) <> [] then (
|
|
Output.print_sstring conf "<li>\n";
|
|
Output.printf conf "%d\n" j;
|
|
(let liste =
|
|
List.sort
|
|
(fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2)
|
|
tab.(pred j)
|
|
in
|
|
print_anniversary_day conf base dead_people liste);
|
|
Output.print_sstring conf "</li>\n")
|
|
done;
|
|
Output.print_sstring conf "</ul>\n";
|
|
Hutil.trailer conf
|
|
|
|
let print_anniversary_list conf base dead_people dt liste =
|
|
let a_ref = dt.year in
|
|
Output.print_sstring conf "<ul>\n";
|
|
List.iter
|
|
(fun (p, a, date_event, txt_of) ->
|
|
Output.print_sstring conf "<li>";
|
|
if dead_people then (
|
|
Output.print_sstring conf "<em>";
|
|
(match date_event with
|
|
| DeBirth -> Output.print_sstring conf (transl conf "birth")
|
|
| DeDeath _ -> Output.print_sstring conf (transl conf "death"));
|
|
Output.print_sstring conf "</em> -> ";
|
|
Output.print_string conf (txt_of conf base p);
|
|
Output.print_sstring conf " <em>";
|
|
Output.print_sstring conf (transl conf "in (year)");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (string_of_int a);
|
|
Output.print_sstring conf " (";
|
|
Output.print_sstring conf
|
|
(Printf.sprintf (ftransl conf "%d years ago") (conf.today.year - a));
|
|
Output.print_sstring conf ")</em>")
|
|
else (
|
|
Output.print_string conf (txt_of conf base p);
|
|
(* TODO year of birth *)
|
|
match get_death p with NotDead -> print_age conf a_ref a | _ -> ());
|
|
Output.print_sstring conf "</li>")
|
|
liste;
|
|
Output.print_sstring conf "</ul>"
|
|
|
|
let f_scan conf base =
|
|
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
|
|
fun () ->
|
|
match next () with
|
|
| Some i -> (pget conf base i, referenced_person_title_text)
|
|
| None -> raise Not_found
|
|
|
|
let print_birth conf base mois =
|
|
gen_print conf base mois (f_scan conf base) false
|
|
|
|
let print_dead conf base mois = gen_print conf base mois (f_scan conf base) true
|
|
|
|
let print_birth_day conf base day_name fphrase wd dt list =
|
|
match list with
|
|
| [] ->
|
|
Output.print_sstring conf "<p>";
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "no birthday"));
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf day_name;
|
|
Output.print_sstring conf ".</p>"
|
|
| _ ->
|
|
Output.print_sstring conf "<p>\n";
|
|
let txt =
|
|
transl_nth conf "(week day)" wd ^ " " ^ DateDisplay.code_dmy conf dt
|
|
|> transl_decline conf "on (weekday day month year)"
|
|
|> Adef.safe
|
|
in
|
|
Output.printf conf fphrase
|
|
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
|
|
^<^ ",\n"
|
|
^<^ std_color conf ("<b>" ^<^ txt ^>^ "</b>")
|
|
: Adef.safe_string
|
|
:> string)
|
|
(transl conf "the birthday");
|
|
Output.print_sstring conf "...</p>";
|
|
print_anniversary_list conf base false dt list
|
|
|
|
let propose_months conf mode =
|
|
begin_centered conf;
|
|
Output.print_sstring conf "<span>";
|
|
transl conf "select a month to see all the anniversaries"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf "</span>";
|
|
Output.print_sstring conf {|<table border="|};
|
|
Output.print_sstring conf (string_of_int conf.border);
|
|
Output.print_sstring conf {|"><tr><td>|};
|
|
Output.print_sstring conf {|<form class="form-inline" method="get" action="|};
|
|
Output.print_sstring conf conf.command;
|
|
Output.print_sstring conf {|"><p>|};
|
|
Util.hidden_env conf;
|
|
mode ();
|
|
Output.print_sstring conf
|
|
{|<select class="form-control form-control-lg" name="v">|};
|
|
for i = 1 to 12 do
|
|
Output.print_sstring conf {|<option value="|};
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf {|"|};
|
|
Output.print_sstring conf
|
|
(if i = conf.today.month then {| selected="selected">|} else ">");
|
|
transl_nth conf "(month)" (i - 1)
|
|
|> Util.translate_eval |> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf "</option>"
|
|
done;
|
|
Output.print_sstring conf "</select>";
|
|
Output.print_sstring conf
|
|
{|<button type="submit" class="btn btn-primary btn-lg ml-2">|};
|
|
transl_nth conf "validate/delete" 0
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf "</button></p></form></td></tr></table>";
|
|
end_centered conf
|
|
|
|
let day_after d =
|
|
let day, r =
|
|
if d.day >= Date.nb_days_in_month d.month d.year then (1, 1)
|
|
else (succ d.day, 0)
|
|
in
|
|
let month, r = if d.month + r > 12 then (1, 1) else (d.month + r, 0) in
|
|
let year = d.year + r in
|
|
{ day; month; year; prec = Sure; delta = 0 }
|
|
|
|
let print_anniv conf base day_name fphrase wd dt = function
|
|
| [] ->
|
|
Output.print_sstring conf "<p>";
|
|
transl conf "no anniversary"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf day_name;
|
|
Output.print_sstring conf ".</p>"
|
|
| list ->
|
|
Output.print_sstring conf "<p>";
|
|
let txt =
|
|
transl_nth conf "(week day)" wd ^ " " ^ DateDisplay.code_dmy conf dt
|
|
|> transl_decline conf "on (weekday day month year)"
|
|
|> Adef.safe
|
|
in
|
|
Output.printf conf fphrase
|
|
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
|
|
^<^ ",\n"
|
|
^<^ std_color conf ("<b>" ^<^ txt ^>^ "</b>")
|
|
: Adef.safe_string
|
|
:> string)
|
|
(transl conf "the anniversary");
|
|
Output.print_sstring conf "...</p>";
|
|
print_anniversary_list conf base true dt list
|
|
|
|
let list_aux conf base list cb =
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun (fam, year) ->
|
|
Output.print_sstring conf "<li>";
|
|
Output.print_string conf
|
|
(referenced_person_title_text conf base
|
|
(pget conf base (get_father fam)));
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl_nth conf "and" 0);
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf
|
|
(referenced_person_title_text conf base
|
|
(pget conf base (get_mother fam)));
|
|
Output.print_sstring conf ", <em>";
|
|
Output.print_sstring conf (transl conf "in (year)");
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (string_of_int year);
|
|
cb conf year;
|
|
Output.print_sstring conf "</em></li>")
|
|
list;
|
|
Output.print_sstring conf "</ul>"
|
|
|
|
let print_marriage conf base month =
|
|
let title _ =
|
|
let lab = transl conf "anniversaries of marriage" in
|
|
Output.printf conf "%s %s" (Utf8.capitalize_fst lab)
|
|
(transl_decline conf "in (month year)"
|
|
(transl_nth conf "(month)" (month - 1)))
|
|
in
|
|
let tab = Array.make 31 [] in
|
|
Hutil.header conf title;
|
|
Gwdb.Collection.iter
|
|
(fun ifam ->
|
|
let fam = foi base ifam in
|
|
match Date.cdate_to_dmy_opt (get_marriage fam) with
|
|
| Some { day = d; month = m; year = y; prec = Sure } when d <> 0 && m <> 0
|
|
->
|
|
let father = pget conf base (get_father fam) in
|
|
let mother = pget conf base (get_mother fam) in
|
|
if
|
|
m = month
|
|
&& authorized_age conf base father
|
|
&& (not (is_hidden father))
|
|
&& authorized_age conf base mother
|
|
&& not (is_hidden mother)
|
|
then tab.(pred d) <- (fam, y) :: tab.(pred d)
|
|
| _ -> ())
|
|
(Gwdb.ifams base);
|
|
Output.print_sstring conf "<ul>";
|
|
for i = 1 to 31 do
|
|
match tab.(i - 1) with
|
|
| [] -> ()
|
|
| list ->
|
|
let list = List.sort (fun (_, y1) (_, y2) -> compare y1 y2) list in
|
|
Output.print_sstring conf " <li>";
|
|
Output.print_sstring conf (string_of_int i);
|
|
list_aux conf base list (fun _ _ -> ());
|
|
Output.print_sstring conf " </li>"
|
|
done;
|
|
Output.print_sstring conf "</ul>";
|
|
Hutil.trailer conf
|
|
|
|
let print_anniversaries_of_marriage conf base list =
|
|
list_aux conf base list (fun conf year ->
|
|
Output.print_sstring conf " (";
|
|
Printf.sprintf (ftransl conf "%d years ago") (conf.today.year - year)
|
|
|> Output.print_sstring conf;
|
|
Output.print_sstring conf ")")
|
|
|
|
let print_marriage_day conf base day_name fphrase wd dt = function
|
|
| [] ->
|
|
Output.print_sstring conf "<p>";
|
|
transl conf "no anniversary"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf day_name;
|
|
Output.print_sstring conf ".</p>"
|
|
| list ->
|
|
Output.print_sstring conf "<p>";
|
|
Output.printf conf fphrase
|
|
(Utf8.capitalize_fst (day_name : Adef.safe_string :> string)
|
|
^<^ ",\n"
|
|
^<^ std_color conf
|
|
("<b>"
|
|
^ transl_decline conf "on (weekday day month year)"
|
|
(transl_nth conf "(week day)" wd
|
|
^ " "
|
|
^ DateDisplay.code_dmy conf dt)
|
|
^ "</b>"
|
|
|> Adef.safe)
|
|
: Adef.safe_string
|
|
:> string)
|
|
(transl conf "the anniversary of marriage");
|
|
Output.print_sstring conf "...</p>";
|
|
print_anniversaries_of_marriage conf base list
|
|
|
|
let match_dates conf base p d1 d2 =
|
|
if d1.day = d2.day && d1.month = d2.month then authorized_age conf base p
|
|
else if
|
|
d1.day = 29 && d1.month = 2 && d2.day = 1 && d2.month = 3
|
|
&& not (Date.leap_year d2.year)
|
|
then authorized_age conf base p
|
|
else false
|
|
|
|
let gen_print_menu_birth conf base f_scan mode =
|
|
let title _ =
|
|
transl conf "birthdays" |> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
let tom = day_after conf.today in
|
|
let aft = day_after tom in
|
|
let list_tod = ref [] in
|
|
let list_tom = ref [] in
|
|
let list_aft = ref [] in
|
|
(match Util.find_person_in_env conf base "" with
|
|
| Some p ->
|
|
Perso.interp_notempl_with_menu title "perso_header" conf base p;
|
|
Output.print_sstring conf "<h2>";
|
|
title false;
|
|
Output.print_sstring conf "</h2>"
|
|
| None -> Hutil.header conf title);
|
|
(try
|
|
while true do
|
|
let p, txt_of = f_scan () in
|
|
match (Date.cdate_to_dmy_opt (get_birth p), get_death p) with
|
|
| Some d, (NotDead | DontKnowIfDead) ->
|
|
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
|
|
if match_dates conf base p d conf.today then
|
|
list_tod := (p, d.year, DeBirth, txt_of) :: !list_tod
|
|
else if match_dates conf base p d tom then
|
|
list_tom := (p, d.year, DeBirth, txt_of) :: !list_tom
|
|
else if match_dates conf base p d aft then
|
|
list_aft := (p, d.year, DeBirth, txt_of) :: !list_aft
|
|
| _ -> ()
|
|
done
|
|
with Not_found -> ());
|
|
List.iter
|
|
(fun xx ->
|
|
xx := List.sort (fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2) !xx)
|
|
[ list_tod; list_tom; list_aft ];
|
|
print_birth_day conf base
|
|
(transl conf "today" |> Adef.safe)
|
|
(ftransl conf "%s, it is %s of")
|
|
conf.today_wd conf.today !list_tod;
|
|
print_birth_day conf base
|
|
(transl conf "tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 1) mod 7)
|
|
tom !list_tom;
|
|
print_birth_day conf base
|
|
(transl conf "the day after tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 2) mod 7)
|
|
aft !list_aft;
|
|
Output.print_sstring conf " ";
|
|
propose_months conf mode;
|
|
Output.print_sstring conf " ";
|
|
Hutil.trailer conf
|
|
|
|
let print_menu_birth conf base =
|
|
let f_scan =
|
|
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
|
|
fun () ->
|
|
match next () with
|
|
| Some i -> (pget conf base i, referenced_person_title_text)
|
|
| None -> raise Not_found
|
|
in
|
|
let mode () =
|
|
Output.print_sstring conf
|
|
"<input type=\"hidden\" name=\"m\" value=\"AN\">\n"
|
|
in
|
|
gen_print_menu_birth conf base f_scan mode
|
|
|
|
let gen_print_menu_dead conf base f_scan mode =
|
|
let title _ =
|
|
transl conf "anniversaries of dead people"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
let tom = day_after conf.today in
|
|
let aft = day_after tom in
|
|
let list_tod = ref [] in
|
|
let list_tom = ref [] in
|
|
let list_aft = ref [] in
|
|
Hutil.header conf title;
|
|
(try
|
|
while true do
|
|
let p, txt_of = f_scan () in
|
|
match get_death p with
|
|
| NotDead | DontKnowIfDead -> ()
|
|
| Death _ | DeadYoung | DeadDontKnowWhen | OfCourseDead -> (
|
|
(match Date.cdate_to_dmy_opt (get_birth p) with
|
|
| None -> ()
|
|
| Some d ->
|
|
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
|
|
if match_dates conf base p d conf.today then
|
|
list_tod := (p, d.year, DeBirth, txt_of) :: !list_tod
|
|
else if match_dates conf base p d tom then
|
|
list_tom := (p, d.year, DeBirth, txt_of) :: !list_tom
|
|
else if match_dates conf base p d aft then
|
|
list_aft := (p, d.year, DeBirth, txt_of) :: !list_aft);
|
|
match get_death p with
|
|
| Death (dr, d) -> (
|
|
match Date.cdate_to_dmy_opt d with
|
|
| None -> ()
|
|
| Some d ->
|
|
if d.prec = Sure && d.day <> 0 && d.month <> 0 then
|
|
if match_dates conf base p d conf.today then
|
|
list_tod := (p, d.year, DeDeath dr, txt_of) :: !list_tod
|
|
else if match_dates conf base p d tom then
|
|
list_tom := (p, d.year, DeDeath dr, txt_of) :: !list_tom
|
|
else if match_dates conf base p d aft then
|
|
list_aft := (p, d.year, DeDeath dr, txt_of) :: !list_aft)
|
|
| NotDead | DeadYoung | DeadDontKnowWhen | DontKnowIfDead
|
|
| OfCourseDead ->
|
|
())
|
|
done
|
|
with Not_found -> ());
|
|
List.iter
|
|
(fun xx ->
|
|
xx := List.sort (fun (_, a1, _, _) (_, a2, _, _) -> compare a1 a2) !xx)
|
|
[ list_tod; list_tom; list_aft ];
|
|
print_anniv conf base
|
|
(transl conf "today" |> Adef.safe)
|
|
(ftransl conf "%s, it is %s of")
|
|
conf.today_wd conf.today !list_tod;
|
|
print_anniv conf base
|
|
(transl conf "tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 1) mod 7)
|
|
tom !list_tom;
|
|
print_anniv conf base
|
|
(transl conf "the day after tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 2) mod 7)
|
|
aft !list_aft;
|
|
Output.print_sstring conf "\n";
|
|
propose_months conf mode;
|
|
Output.print_sstring conf "\n";
|
|
Hutil.trailer conf
|
|
|
|
let print_menu_dead conf base =
|
|
let f_scan =
|
|
let next = Gwdb.Collection.iterator (Gwdb.ipers base) in
|
|
fun () ->
|
|
match next () with
|
|
| Some i -> (pget conf base i, referenced_person_title_text)
|
|
| None -> raise Not_found
|
|
in
|
|
gen_print_menu_dead conf base f_scan (fun () ->
|
|
Util.hidden_input conf "m" @@ Adef.encoded "AD")
|
|
|
|
let match_mar_dates conf base cpl d1 d2 =
|
|
if d1.day = d2.day && d1.month = d2.month then
|
|
authorized_age conf base (pget conf base (get_father cpl))
|
|
&& authorized_age conf base (pget conf base (get_mother cpl))
|
|
else if
|
|
d1.day = 29 && d1.month = 2 && d2.day = 1 && d2.month = 3
|
|
&& not (Date.leap_year d2.year)
|
|
then
|
|
authorized_age conf base (pget conf base (get_father cpl))
|
|
&& authorized_age conf base (pget conf base (get_mother cpl))
|
|
else false
|
|
|
|
let print_menu_marriage conf base =
|
|
let title _ =
|
|
transl conf "anniversaries of marriage"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
in
|
|
let tom = day_after conf.today in
|
|
let aft = day_after tom in
|
|
let list_tod = ref [] in
|
|
let list_tom = ref [] in
|
|
let list_aft = ref [] in
|
|
Hutil.header conf title;
|
|
Gwdb.Collection.iter
|
|
(fun ifam ->
|
|
let fam = foi base ifam in
|
|
match (Date.cdate_to_dmy_opt (get_marriage fam), get_divorce fam) with
|
|
| Some d, NotDivorced when d.day <> 0 && d.month <> 0 && d.prec = Sure ->
|
|
let update_list cpl =
|
|
if match_mar_dates conf base cpl d conf.today then
|
|
list_tod := (cpl, d.year) :: !list_tod
|
|
else if match_mar_dates conf base cpl d tom then
|
|
list_tom := (cpl, d.year) :: !list_tom
|
|
else if match_mar_dates conf base cpl d aft then
|
|
list_aft := (cpl, d.year) :: !list_aft
|
|
in
|
|
if conf.use_restrict then (
|
|
let father = pget conf base (get_father fam) in
|
|
let mother = pget conf base (get_mother fam) in
|
|
if (not (is_hidden father)) && not (is_hidden mother) then
|
|
update_list fam)
|
|
else update_list fam
|
|
| _ -> ())
|
|
(Gwdb.ifams base);
|
|
List.iter
|
|
(fun xx -> xx := List.sort (fun (_, y1) (_, y2) -> compare y1 y2) !xx)
|
|
[ list_tod; list_tom; list_aft ];
|
|
print_marriage_day conf base
|
|
(transl conf "today" |> Adef.safe)
|
|
(ftransl conf "%s, it is %s of")
|
|
conf.today_wd conf.today !list_tod;
|
|
print_marriage_day conf base
|
|
(transl conf "tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 1) mod 7)
|
|
tom !list_tom;
|
|
print_marriage_day conf base
|
|
(transl conf "the day after tomorrow" |> Adef.safe)
|
|
(ftransl conf "%s, it will be %s of")
|
|
((conf.today_wd + 2) mod 7)
|
|
aft !list_aft;
|
|
Output.print_sstring conf "\n";
|
|
propose_months conf (fun () ->
|
|
Util.hidden_input conf "m" @@ Adef.encoded "AM");
|
|
Output.print_sstring conf "\n";
|
|
Hutil.trailer conf
|
|
|
|
(* template *)
|
|
type 'a env = Vother of 'a
|
|
|
|
let get_vother = function Vother x -> Some x
|
|
let set_vother x = Vother x
|
|
|
|
let print_anniversaries conf =
|
|
if p_getenv conf.env "old" = Some "on" then ()
|
|
else
|
|
Hutil.interp conf "annivmenu"
|
|
{
|
|
Templ.eval_var = (fun _ -> raise Not_found);
|
|
Templ.eval_transl = (fun _ -> Templ.eval_transl conf);
|
|
Templ.eval_predefined_apply = (fun _ -> raise Not_found);
|
|
Templ.get_vother;
|
|
Templ.set_vother;
|
|
Templ.print_foreach = (fun _ -> raise Not_found);
|
|
}
|
|
[] ()
|