320 lines
11 KiB
OCaml
320 lines
11 KiB
OCaml
open Config
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
open Title
|
|
|
|
let my_alphabetic n1 n2 = compare (Name.lower n1) (Name.lower n2)
|
|
|
|
let string_cnt_list_uniq l =
|
|
let l =
|
|
List.fold_left
|
|
(fun l (e, c) ->
|
|
match l with
|
|
| [] -> [ (e, c) ]
|
|
| (x, d) :: l1 ->
|
|
if my_alphabetic e x = 0 then (x, c + d) :: l1 else (e, c) :: l)
|
|
[] l
|
|
in
|
|
List.rev l
|
|
|
|
let compare_titles2 (t1, _) (t2, _) = my_alphabetic t1 t2
|
|
|
|
let give_access_someone conf base (x, t) list =
|
|
let t_date_start = Date.cdate_to_dmy_opt t.t_date_start in
|
|
let t_date_end = Date.cdate_to_dmy_opt t.t_date_end in
|
|
let has_dates =
|
|
match (t_date_start, t_date_end) with
|
|
| Some _d, _ | _, Some _d -> true
|
|
| _ -> false
|
|
in
|
|
if has_dates then Output.print_sstring conf "<em>";
|
|
(match t_date_start with
|
|
| None -> ()
|
|
| Some d -> Output.print_sstring conf (string_of_int d.year));
|
|
(match t_date_end with
|
|
| None -> ()
|
|
| Some d ->
|
|
Output.print_sstring conf "-";
|
|
Output.print_sstring conf (string_of_int d.year));
|
|
if has_dates then Output.print_sstring conf "</em>: ";
|
|
if List.mem x list then Output.print_sstring conf "<em>"
|
|
else
|
|
Output.print_string conf
|
|
({|<a href="|} ^<^ commd conf ^^^ acces conf base x ^>^ {|">|});
|
|
(match (t.t_name, get_public_name x, get_qualifiers x) with
|
|
| Tmain, pn, nn :: _ when sou base pn <> "" ->
|
|
Output.print_string conf (escape_html @@ sou base pn);
|
|
Output.print_sstring conf " <em>";
|
|
Output.print_string conf (escape_html @@ sou base nn);
|
|
Output.print_sstring conf "</em> ";
|
|
Output.print_string conf (escape_html @@ p_surname base x)
|
|
| Tmain, pn, [] when sou base pn <> "" ->
|
|
Output.print_string conf (escape_html @@ sou base pn);
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (escape_html @@ p_surname base x)
|
|
| Tname n, _, nn :: _ ->
|
|
Output.print_string conf (escape_html @@ sou base n);
|
|
Output.print_sstring conf " <em>";
|
|
Output.print_string conf (escape_html @@ sou base nn);
|
|
Output.print_sstring conf "</em> ";
|
|
Output.print_string conf (escape_html @@ p_surname base x)
|
|
| Tname n, _, [] ->
|
|
Output.print_string conf (escape_html @@ sou base n);
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (escape_html @@ p_surname base x)
|
|
| _ -> Output.print_string conf (gen_person_text conf base x));
|
|
Output.print_sstring conf "\n";
|
|
Output.print_string conf (DateDisplay.short_dates_text conf base x);
|
|
if t.t_nth <> 0 then (
|
|
Output.print_sstring conf " (";
|
|
Output.print_sstring conf
|
|
(if t.t_nth >= 100 then string_of_int t.t_nth
|
|
else transl_nth conf "nth" t.t_nth);
|
|
Output.print_sstring conf ")");
|
|
if List.mem x list then Output.print_sstring conf "</em>"
|
|
else Output.print_sstring conf "</a>"
|
|
|
|
let give_access_title_aux conf xhref content =
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=TT&sm=S";
|
|
Output.print_string conf xhref;
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_string conf content;
|
|
Output.print_sstring conf "</a>"
|
|
|
|
let give_access_title conf t p =
|
|
give_access_title_aux conf
|
|
("&t=" ^<^ Mutil.encode t ^^^ "&p=" ^<^ Mutil.encode p)
|
|
(escape_html @@ Utf8.capitalize_fst t)
|
|
|
|
let give_access_all_titles conf t absolute =
|
|
give_access_title_aux conf
|
|
("&t=" ^<^ Mutil.encode t ^>^ if absolute then "&a=A" else "")
|
|
(escape_html @@ if absolute then t else Utf8.capitalize_fst t)
|
|
|
|
let give_access_all_places conf t =
|
|
give_access_title_aux conf
|
|
("&p=" ^<^ Mutil.encode t)
|
|
("... " ^<^ escape_html t)
|
|
|
|
let propose_tree_for_list list conf =
|
|
let list, _ =
|
|
List.fold_left
|
|
(fun (list, n) (p, _) ->
|
|
let list = if List.mem_assq p list then list else (p, n) :: list in
|
|
(list, n + 1))
|
|
([], 1) list
|
|
in
|
|
match List.rev list with
|
|
| _ :: _ :: _ as list ->
|
|
Output.print_sstring conf {|<p><a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf {|m=RLM|};
|
|
ignore
|
|
@@ List.fold_left
|
|
(fun i (p, n) ->
|
|
Output.print_sstring conf "&i";
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf "=";
|
|
Output.print_sstring conf (Gwdb.string_of_iper @@ get_iper p);
|
|
Output.print_sstring conf "&t";
|
|
Output.print_sstring conf (string_of_int i);
|
|
Output.print_sstring conf "=";
|
|
Output.print_sstring conf (string_of_int n);
|
|
i + 1)
|
|
1 list;
|
|
Output.print_sstring conf {|&lim=6">|};
|
|
Output.print_sstring conf (Utf8.capitalize_fst (transl conf "tree"));
|
|
Output.print_sstring conf {|</a></p>|}
|
|
| _ -> ()
|
|
|
|
let print_title_place_list conf base t p t_equiv list =
|
|
let absolute = p_getenv conf.env "a" = Some "A" in
|
|
let title h =
|
|
if h || absolute then (
|
|
Output.print_string conf (escape_html t);
|
|
if p <> "" then (
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (escape_html p)))
|
|
else
|
|
Mutil.list_iter_first
|
|
(fun first t ->
|
|
if not first then Output.print_sstring conf ", ";
|
|
give_access_title_aux conf
|
|
("&a=A&t=" ^<^ Mutil.encode t)
|
|
(escape_html t);
|
|
if p <> "" then (
|
|
Output.print_sstring conf " ";
|
|
give_access_title_aux conf
|
|
("&a=A&p=" ^<^ Mutil.encode p)
|
|
(escape_html p)))
|
|
t_equiv
|
|
in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul>";
|
|
ignore
|
|
@@ List.fold_left
|
|
(fun list x ->
|
|
Output.print_sstring conf "<li>";
|
|
give_access_someone conf base x list;
|
|
Output.print_sstring conf "</li>";
|
|
fst x :: list)
|
|
[] list;
|
|
Output.print_sstring conf "</ul>";
|
|
propose_tree_for_list list conf;
|
|
Hutil.trailer conf
|
|
|
|
let print_all_with_place_list conf base p list =
|
|
let title _ =
|
|
Output.print_sstring conf "... ";
|
|
Output.print_string conf (escape_html p)
|
|
in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul>\n";
|
|
List.iter
|
|
(fun ((_, t) as x) ->
|
|
Output.print_sstring conf "<li>";
|
|
give_access_someone conf base x [];
|
|
Output.print_sstring conf ", ";
|
|
Output.print_string conf (sou base t.t_ident |> escape_html);
|
|
Output.printf conf "<li>")
|
|
list;
|
|
Output.print_sstring conf "</ul>\n";
|
|
propose_tree_for_list list conf;
|
|
Hutil.trailer conf
|
|
|
|
let select_title_place conf base title place =
|
|
select_title_place conf base title place
|
|
~absolute:(p_getenv conf.env "a" = Some "A")
|
|
|
|
let select_title conf base title =
|
|
select_title conf base title ~absolute:(p_getenv conf.env "a" = Some "A")
|
|
|
|
let print_title_place conf base t p =
|
|
let l, t, p, t_equiv = select_title_place conf base t p in
|
|
let list = List.sort (compare_title_order conf base) l in
|
|
print_title_place_list conf base t p t_equiv list
|
|
|
|
let print_all_with_place conf base p =
|
|
let l, p = select_all_with_place conf base p in
|
|
let list = List.sort (compare_title_dates conf base) l in
|
|
print_all_with_place_list conf base p list
|
|
|
|
let print_places_list conf base t t_equiv list =
|
|
let title h =
|
|
if h || List.length t_equiv = 1 then
|
|
Output.print_string conf (escape_html t)
|
|
else
|
|
Mutil.list_iter_first
|
|
(fun first t ->
|
|
Output.print_sstring conf (if first then "" else ", ");
|
|
give_access_all_titles conf t true)
|
|
t_equiv
|
|
in
|
|
let order s =
|
|
Utf8.capitalize_fst (Name.lower (surname_without_particle base s))
|
|
in
|
|
let list = List.sort (fun s1 s2 -> compare (order s1) (order s2)) list in
|
|
let absolute = p_getenv conf.env "a" = Some "A" in
|
|
let wprint_elem p =
|
|
give_access_title_aux conf
|
|
("&t=" ^<^ Mutil.encode t ^^^ "&p=" ^<^ Mutil.encode p
|
|
^>^ if absolute then "&a=A" else "")
|
|
(if p = "" then Adef.safe "..."
|
|
else
|
|
((escape_html @@ surname_without_particle base p)
|
|
^^^ escape_html @@ surname_particle base p
|
|
:> Adef.safe_string))
|
|
in
|
|
Hutil.header conf title;
|
|
wprint_in_columns conf order wprint_elem list;
|
|
Hutil.trailer conf
|
|
|
|
let print_places conf base t =
|
|
let l, t, t_equiv = select_title conf base t in
|
|
let list = List.sort_uniq my_alphabetic l in
|
|
match list with
|
|
| [ p ] -> print_title_place conf base t p
|
|
| _ -> print_places_list conf base t t_equiv list
|
|
|
|
let print_titles conf base p =
|
|
let l, p = select_place conf base p in
|
|
let list = List.sort_uniq my_alphabetic l in
|
|
let title _ =
|
|
Output.print_sstring conf "... ";
|
|
Output.print_string conf (escape_html p)
|
|
in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul>\n";
|
|
List.iter
|
|
(fun t ->
|
|
Output.print_sstring conf "<li>";
|
|
give_access_title conf t p;
|
|
Output.print_sstring conf "</li>\n")
|
|
list;
|
|
Output.print_sstring conf "</ul>\n";
|
|
if List.length list > 1 then (
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=TT&sm=A&p=";
|
|
Output.print_string conf (Mutil.encode p);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "the whole list"));
|
|
Output.print_sstring conf "</a>");
|
|
Hutil.trailer conf
|
|
|
|
let print_all_titles conf base =
|
|
let title _ =
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "all the titles"))
|
|
in
|
|
let list =
|
|
let l = select_all_titles conf base in
|
|
string_cnt_list_uniq (List.sort compare_titles2 l)
|
|
in
|
|
let order (s, _) = Utf8.capitalize_fst (Name.lower s) in
|
|
let wprint_elem (t, cnt) =
|
|
give_access_all_titles conf t false;
|
|
Output.printf conf " (%d)" cnt
|
|
in
|
|
Hutil.header conf title;
|
|
wprint_in_columns conf order wprint_elem list;
|
|
Hutil.trailer conf
|
|
|
|
let print_all_places conf base =
|
|
let title _ =
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl conf "all the estates"))
|
|
in
|
|
let list =
|
|
let l = select_all_places conf base in
|
|
List.sort_uniq my_alphabetic l
|
|
in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul>\n";
|
|
List.iter
|
|
(fun t ->
|
|
Output.print_sstring conf "<li>";
|
|
give_access_all_places conf t;
|
|
Output.print_sstring conf "</li>\n")
|
|
list;
|
|
Output.print_sstring conf "</ul>\n";
|
|
Hutil.trailer conf
|
|
|
|
let print conf base =
|
|
match
|
|
(p_getenv conf.env "sm", p_getenv conf.env "t", p_getenv conf.env "p")
|
|
with
|
|
| Some "S", Some t, Some p -> print_title_place conf base t p
|
|
| Some "S", Some t, None -> print_places conf base t
|
|
| Some "S", None, Some p -> print_titles conf base p
|
|
| Some "A", None, Some p -> print_all_with_place conf base p
|
|
| _, (Some "" | None), (Some "" | None) -> print_all_titles conf base
|
|
| _, (Some "" | None), Some "*" -> print_all_places conf base
|
|
| _, (Some "" | None), Some p -> print_titles conf base p
|
|
| _, Some t, (Some "" | None) -> print_places conf base t
|
|
| _, Some t, Some p -> print_title_place conf base t p
|