223 lines
7.9 KiB
OCaml
223 lines
7.9 KiB
OCaml
(* Copyright (c) 1998-2007 INRIA *)
|
|
|
|
open Config
|
|
open Gwdb
|
|
open Util
|
|
|
|
let print_html_places_surnames conf base
|
|
(array : (string list * (string * iper list) list) array) =
|
|
let link_to_ind =
|
|
List.assoc_opt "place_surname_link_to_ind" conf.base_env = Some "yes"
|
|
in
|
|
let print_sn (sn, ips) =
|
|
let len = List.length ips in
|
|
Output.print_sstring conf "<a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
match ips with
|
|
| [ ips ] when link_to_ind ->
|
|
Output.print_string conf (acces conf base @@ pget conf base @@ ips)
|
|
| _ ->
|
|
Output.print_sstring conf "m=N&v=";
|
|
Output.print_string conf (Mutil.encode sn);
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf (escape_html sn);
|
|
Output.print_sstring conf "</a> (";
|
|
Output.print_sstring conf (string_of_int len);
|
|
Output.print_sstring conf ")"
|
|
in
|
|
let print_sn_list (snl : (string * iper list) list) =
|
|
let snl =
|
|
List.sort (fun (sn1, _) (sn2, _) -> Gutil.alphabetic_order sn1 sn2) snl
|
|
in
|
|
Output.print_sstring conf "<li>\n";
|
|
Mutil.list_iter_first
|
|
(fun first x ->
|
|
if not first then Output.print_sstring conf ",\n";
|
|
print_sn x)
|
|
snl;
|
|
Output.print_sstring conf "\n";
|
|
Output.print_sstring conf "</li>\n"
|
|
in
|
|
let rec loop prev = function
|
|
| (pl, snl) :: list ->
|
|
let rec loop1 prev pl =
|
|
match (prev, pl) with
|
|
| [], l2 ->
|
|
List.iter (fun x -> Output.printf conf "<li>%s<ul>\n" x) l2
|
|
| x1 :: l1, x2 :: l2 ->
|
|
if x1 = x2 then loop1 l1 l2
|
|
else (
|
|
List.iter
|
|
(fun _ -> Output.print_sstring conf "</ul></li>\n")
|
|
(x1 :: l1);
|
|
loop1 [] (x2 :: l2))
|
|
| _ -> assert false
|
|
in
|
|
loop1 prev pl;
|
|
print_sn_list snl;
|
|
loop pl list
|
|
| [] -> List.iter (fun _ -> Output.print_sstring conf "</ul></li>\n") prev
|
|
in
|
|
Output.print_sstring conf "<ul>\n";
|
|
loop [] (Array.to_list array);
|
|
Output.print_sstring conf "</ul>\n"
|
|
|
|
let print_aux_opt ~add_birth ~add_baptism ~add_death ~add_burial ~add_marriage =
|
|
Adef.encoded
|
|
@@ (if add_birth then "&bi=on" else "")
|
|
^ (if add_baptism then "&bp=on" else "")
|
|
^ (if add_death then "&de=on" else "")
|
|
^ (if add_burial then "&bu=on" else "")
|
|
^ if add_marriage then "&ma=on" else ""
|
|
|
|
let print_aux conf title fn =
|
|
Hutil.header conf title;
|
|
Hutil.print_link_to_welcome conf true;
|
|
fn ();
|
|
Hutil.trailer conf
|
|
|
|
let print_all_places_surnames_short conf base ~add_birth ~add_baptism ~add_death
|
|
~add_burial ~add_marriage =
|
|
let inverted =
|
|
try List.assoc "places_inverted" conf.base_env = "yes"
|
|
with Not_found -> false
|
|
in
|
|
let array =
|
|
Place.get_all conf base ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage "" 0
|
|
(Place.fold_place_short inverted)
|
|
(fun _ -> true)
|
|
(fun prev _ -> match prev with Some n -> n + 1 | None -> 1)
|
|
(fun x -> x)
|
|
max_int
|
|
in
|
|
Array.sort (fun (s1, _) (s2, _) -> Gutil.alphabetic_order s1 s2) array;
|
|
let title _ =
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_nth conf "place/places" 0))
|
|
in
|
|
print_aux conf title (fun () ->
|
|
let opt =
|
|
print_aux_opt ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage
|
|
in
|
|
Output.print_sstring conf "<p><a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=PS";
|
|
Output.print_string conf opt;
|
|
Output.print_sstring conf "&display=long\">";
|
|
Output.print_sstring conf (transl conf "long display");
|
|
Output.print_sstring conf "</a></p><p>";
|
|
let last = Array.length array - 1 in
|
|
Array.iteri
|
|
(fun i (s, x) ->
|
|
Output.print_sstring conf "<a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=PS";
|
|
Output.print_string conf opt;
|
|
Output.print_sstring conf "&k=";
|
|
Output.print_string conf (Mutil.encode s);
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf (escape_html s);
|
|
Output.print_sstring conf "</a> (";
|
|
Output.print_sstring conf (string_of_int x);
|
|
Output.print_sstring conf ")";
|
|
if i <> last then Output.print_sstring conf ", ")
|
|
array;
|
|
Output.print_sstring conf "</p>\n")
|
|
|
|
let print_all_places_surnames_long conf base ini ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage max_length =
|
|
let filter =
|
|
if ini = "" then ( <> ) []
|
|
else function x :: _ when x = ini -> true | _ -> false
|
|
in
|
|
let inverted =
|
|
try List.assoc "places_inverted" conf.base_env = "yes"
|
|
with Not_found -> false
|
|
in
|
|
let array =
|
|
Place.get_all conf base ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage [] []
|
|
(Place.fold_place_long_v6 inverted)
|
|
filter
|
|
(fun prev p ->
|
|
let value = (get_surname p, get_iper p) in
|
|
match prev with Some list -> value :: list | None -> [ value ])
|
|
(fun v ->
|
|
let v = List.sort (fun (a, _) (b, _) -> compare a b) v in
|
|
let rec loop acc list =
|
|
match (list, acc) with
|
|
| [], _ -> acc
|
|
| (sn, iper) :: tl_list, (sn', iper_list) :: tl_acc
|
|
when sou base sn = sn' ->
|
|
loop ((sn', iper :: iper_list) :: tl_acc) tl_list
|
|
| (sn, iper) :: tl_list, _ ->
|
|
loop ((sou base sn, [ iper ]) :: acc) tl_list
|
|
in
|
|
loop [] v)
|
|
max_length
|
|
in
|
|
let rec sort_place_utf8 pl1 pl2 =
|
|
match (pl1, pl2) with
|
|
| _, [] -> 1
|
|
| [], _ -> -1
|
|
| s1 :: pl11, s2 :: pl22 -> (
|
|
match Gutil.alphabetic_order s1 s2 with
|
|
| 0 -> sort_place_utf8 pl11 pl22
|
|
| x -> x)
|
|
in
|
|
Array.sort (fun (pl1, _) (pl2, _) -> sort_place_utf8 pl1 pl2) array;
|
|
let title _ =
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_nth conf "place/places" 0));
|
|
Output.print_sstring conf " / ";
|
|
Output.print_sstring conf
|
|
(Utf8.capitalize_fst (transl_nth conf "surname/surnames" 0))
|
|
in
|
|
print_aux conf title (fun () ->
|
|
if ini = "" then (
|
|
Output.print_sstring conf "<p><a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=PS";
|
|
Output.print_string conf
|
|
(print_aux_opt ~add_birth ~add_baptism ~add_death ~add_burial
|
|
~add_marriage);
|
|
Output.print_sstring conf "&display=short\">";
|
|
Output.print_sstring conf (transl conf "short display");
|
|
Output.print_sstring conf "</a></p><p>");
|
|
if array <> [||] then print_html_places_surnames conf base array)
|
|
|
|
let print_all_places_surnames conf base =
|
|
let add_marriage = p_getenv conf.env "ma" = Some "on" in
|
|
let add_birth = p_getenv conf.env "bi" = Some "on" in
|
|
let add_baptism = p_getenv conf.env "bp" = Some "on" in
|
|
let add_death = p_getenv conf.env "de" = Some "on" in
|
|
let add_burial = p_getenv conf.env "bu" = Some "on" in
|
|
match p_getenv conf.env "k" with
|
|
| Some ini ->
|
|
print_all_places_surnames_long conf base ini ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage max_int
|
|
| None -> (
|
|
match p_getenv conf.env "display" with
|
|
| Some "long" ->
|
|
print_all_places_surnames_long conf base "" ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage max_int
|
|
| Some "short" ->
|
|
print_all_places_surnames_short conf base ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage
|
|
| Some _ -> assert false
|
|
| None -> (
|
|
try
|
|
let lim =
|
|
try
|
|
int_of_string
|
|
@@ List.assoc "short_place_threshold" conf.base_env
|
|
with _ -> 500
|
|
in
|
|
print_all_places_surnames_long conf base "" ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage lim
|
|
with Place.List_too_long ->
|
|
print_all_places_surnames_short conf base ~add_birth ~add_baptism
|
|
~add_death ~add_burial ~add_marriage))
|