323 lines
12 KiB
OCaml
323 lines
12 KiB
OCaml
open Def
|
|
open Config
|
|
open Gwdb
|
|
open Util
|
|
|
|
let default_max_cnt = Alln.default_max_cnt
|
|
|
|
(* tools *)
|
|
|
|
let particle_at_the_end base is_surnames s =
|
|
if is_surnames then surname_without_particle base s ^ surname_particle base s
|
|
else s
|
|
|
|
let compare_particle_at_the_end base is_surnames a b =
|
|
Gutil.alphabetic_order
|
|
(particle_at_the_end base is_surnames a)
|
|
(particle_at_the_end base is_surnames b)
|
|
|
|
(* print *)
|
|
|
|
let print_title conf base is_surnames ini len =
|
|
if len >= 2 then
|
|
if is_surnames then
|
|
Printf.sprintf (fcapitale (ftransl conf "the %d surnames")) len
|
|
|> Output.print_sstring conf
|
|
else
|
|
Printf.sprintf (fcapitale (ftransl conf "the %d first names")) len
|
|
|> Output.print_sstring conf
|
|
else if is_surnames then
|
|
transl_nth conf "surname/surnames" 0
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf
|
|
else
|
|
transl_nth conf "first name/first names" 0
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
if ini <> "" then (
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf (transl conf "starting with");
|
|
Output.print_sstring conf " ";
|
|
Output.print_string conf (Util.escape_html ini))
|
|
else (
|
|
Output.print_sstring conf " (";
|
|
Output.print_sstring conf (string_of_int @@ Gwdb.nb_of_real_persons base);
|
|
Output.print_sstring conf " ";
|
|
Output.print_sstring conf
|
|
(Util.translate_eval ("@(c)" ^ transl_nth conf "person/persons" 1));
|
|
Output.print_sstring conf ")")
|
|
|
|
let tr c1 s2 s =
|
|
let rec loop i len =
|
|
if i = String.length s then Buff.get len
|
|
else if String.unsafe_get s i = c1 then loop (i + 1) (Buff.mstore len s2)
|
|
else loop (i + 1) (Buff.store len (String.unsafe_get s i))
|
|
in
|
|
loop 0 0
|
|
|
|
let print_alphabetic_big conf base is_surnames ini list len too_big =
|
|
let title _ = print_title conf base is_surnames ini len in
|
|
let mode = if is_surnames then Adef.encoded "N" else Adef.encoded "P" in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf {|<p class="search_name">|};
|
|
List.iter
|
|
(fun ini_k ->
|
|
if ini_k = ini then (
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&tri=A&v=";
|
|
Output.print_string conf (Mutil.encode ini_k);
|
|
Output.print_sstring conf {|">|})
|
|
else (
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&tri=A&k=";
|
|
Output.print_string conf (Mutil.encode ini_k);
|
|
Output.print_sstring conf {|">|});
|
|
Output.print_string conf (tr '_' " " ini_k |> Util.escape_html);
|
|
Output.print_sstring conf "</a>\n")
|
|
list;
|
|
if not too_big then (
|
|
Output.print_sstring conf "</p><p>";
|
|
transl conf "the whole list"
|
|
|> Utf8.capitalize_fst |> Output.print_sstring conf;
|
|
Output.print_sstring conf (transl conf ":");
|
|
Output.print_sstring conf "</p><ul><li>";
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&tri=A&o=A&k=";
|
|
Output.print_string conf (Mutil.encode ini);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf (transl conf "long display");
|
|
Output.print_sstring conf "</a></li><li>";
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&tri=S&o=A&k=";
|
|
Output.print_string conf (Mutil.encode ini);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf (transl conf "short display");
|
|
Output.print_sstring conf "</a></li><li>";
|
|
Output.print_sstring conf {|<a href="|};
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&tri=S&o=A&cgl=on&k=";
|
|
Output.print_string conf (Mutil.encode ini);
|
|
Output.print_sstring conf {|">|};
|
|
Output.print_sstring conf (transl conf "short display");
|
|
Output.print_sstring conf " + ";
|
|
Output.print_sstring conf (transl conf "cancel GeneWeb links");
|
|
Output.print_sstring conf "</a></li></ul>");
|
|
Hutil.trailer conf
|
|
|
|
let print_alphabetic_all conf base is_surnames ini list len =
|
|
let title _ = print_title conf base is_surnames ini len in
|
|
let mode = Adef.encoded (if is_surnames then "N" else "P") in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf {|<p class="search_name">|};
|
|
List.iter
|
|
(fun (ini_k, _) ->
|
|
Output.print_sstring conf "<a href=\"#a";
|
|
Output.print_string conf (Mutil.encode ini_k);
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Adef.safe);
|
|
Output.print_sstring conf "</a>\n")
|
|
list;
|
|
Output.print_sstring conf "</p><ul>";
|
|
List.iter
|
|
(fun (ini_k, l) ->
|
|
Output.print_sstring conf "<li><a id=\"a";
|
|
Output.print_string conf (Mutil.encode ini_k);
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Adef.safe);
|
|
Output.print_sstring conf "</a><ul>";
|
|
List.iter
|
|
(fun (s, cnt) ->
|
|
Output.print_sstring conf "<li>";
|
|
let href = "m=" ^<^ mode ^^^ "&v=" ^<^ Mutil.encode s ^>^ "&t=A" in
|
|
wprint_geneweb_link conf
|
|
(href :> Adef.escaped_string)
|
|
(particle_at_the_end base is_surnames s |> Util.escape_html
|
|
:> Adef.safe_string);
|
|
Output.print_sstring conf " (";
|
|
Output.print_sstring conf (string_of_int cnt);
|
|
Output.print_sstring conf ")</li>")
|
|
(List.sort
|
|
(fun (a, _) (b, _) ->
|
|
compare_particle_at_the_end base is_surnames a b)
|
|
l);
|
|
Output.print_sstring conf "</ul></li>")
|
|
list;
|
|
Output.print_sstring conf "</ul>";
|
|
Hutil.trailer conf
|
|
|
|
let print_alphabetic_small conf base is_surnames ini list len =
|
|
let title _ = print_title conf base is_surnames ini len in
|
|
let mode = Adef.encoded (if is_surnames then "N" else "P") in
|
|
Hutil.header conf title;
|
|
if list <> [] then (
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun (_, s, cnt) ->
|
|
Output.print_sstring conf "<li>";
|
|
Output.print_sstring conf "<a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&v=";
|
|
Output.print_string conf (Mutil.encode s);
|
|
Output.print_sstring conf "&t=A\">";
|
|
Output.print_string conf
|
|
(particle_at_the_end base is_surnames s |> Util.escape_html);
|
|
Output.print_sstring conf "</a> (";
|
|
Output.print_sstring conf (string_of_int cnt);
|
|
Output.print_sstring conf ")</li>")
|
|
(List.sort
|
|
(fun (_, a, _) (_, b, _) ->
|
|
compare_particle_at_the_end base is_surnames a b)
|
|
list);
|
|
Output.print_sstring conf "</ul>");
|
|
Hutil.trailer conf
|
|
|
|
let print_frequency_any conf base is_surnames list len =
|
|
let title _ = print_title conf base is_surnames "" len in
|
|
let mode = Adef.encoded (if is_surnames then "N" else "P") in
|
|
let n = ref 0 in
|
|
Hutil.header conf title;
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun (cnt, l) ->
|
|
if !n <= default_max_cnt then (
|
|
Output.print_sstring conf "<li>";
|
|
Output.print_sstring conf (string_of_int cnt);
|
|
Output.print_sstring conf "<ul>";
|
|
List.iter
|
|
(fun s ->
|
|
Output.print_sstring conf "<li><a href=\"";
|
|
Output.print_string conf (commd conf);
|
|
Output.print_sstring conf "m=";
|
|
Output.print_string conf mode;
|
|
Output.print_sstring conf "&v=";
|
|
Output.print_string conf (Mutil.encode (Name.lower s));
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf
|
|
(particle_at_the_end base is_surnames s |> Util.escape_html);
|
|
Output.print_sstring conf "</a></li>";
|
|
incr n)
|
|
l;
|
|
Output.print_sstring conf "</ul>";
|
|
Output.print_sstring conf "</li>"))
|
|
list;
|
|
Output.print_sstring conf "</ul>";
|
|
Hutil.trailer conf
|
|
|
|
let print_frequency conf base is_surnames =
|
|
let () = load_strings_array base in
|
|
let list, len = Alln.select_names conf base is_surnames "" max_int in
|
|
let list = Alln.groupby_count list in
|
|
print_frequency_any conf base is_surnames list len
|
|
|
|
let print_alphabetic conf base is_surnames =
|
|
let ini = match p_getenv conf.env "k" with Some k -> k | _ -> "" in
|
|
if List.assoc_opt "fast_alphabetic" conf.base_env = Some "yes" && ini = ""
|
|
then (
|
|
load_strings_array base;
|
|
let list = Alln.first_letters base is_surnames in
|
|
let list = List.sort Gutil.alphabetic_order list in
|
|
print_alphabetic_big conf base is_surnames ini list 1 true)
|
|
else
|
|
let all =
|
|
match p_getenv conf.env "o" with Some "A" -> true | _ -> false
|
|
in
|
|
if String.length ini < 2 then load_strings_array base;
|
|
let list, len =
|
|
Alln.select_names conf base is_surnames ini (if all then max_int else 50)
|
|
in
|
|
match list with
|
|
| Alln.Specify keys ->
|
|
let keys = List.sort Gutil.alphabetic_order keys in
|
|
let too_big = (not all) && List.length keys > Alln.default_max_cnt in
|
|
print_alphabetic_big conf base is_surnames ini keys len too_big
|
|
| Alln.Result list ->
|
|
if len >= 50 || ini = "" then
|
|
let list = Alln.groupby_ini (Utf8.length ini + 1) list in
|
|
print_alphabetic_all conf base is_surnames ini list len
|
|
else print_alphabetic_small conf base is_surnames ini list len
|
|
|
|
(* short print *)
|
|
|
|
let print_alphabetic_short conf base is_surnames ini list len =
|
|
let title _ = print_title conf base is_surnames ini len in
|
|
let mode = Adef.encoded (if is_surnames then "N" else "P") in
|
|
let need_ref = len >= 250 in
|
|
Hutil.header conf title;
|
|
if need_ref then (
|
|
Output.print_sstring conf "<p>";
|
|
List.iter
|
|
(fun (ini_k, _) ->
|
|
Output.print_sstring conf "<a href=\"#a";
|
|
Output.print_string conf (Mutil.encode ini_k);
|
|
Output.print_sstring conf "\">";
|
|
Output.print_string conf (Mutil.tr '_' ' ' ini_k |> Util.escape_html);
|
|
Output.print_sstring conf "</a>\n")
|
|
list;
|
|
Output.print_sstring conf "</p>");
|
|
List.iter
|
|
(fun (ini_k, l) ->
|
|
Output.print_sstring conf "<p>";
|
|
Mutil.list_iter_first
|
|
(fun first (s, cnt) ->
|
|
let href =
|
|
" href=\"" ^<^ commd conf
|
|
^^^ ("m=" ^<^ mode ^^^ "&v=" ^<^ Mutil.encode s ^>^ "&t=A\""
|
|
:> Adef.escaped_string)
|
|
in
|
|
let name =
|
|
Adef.encoded
|
|
(if first && need_ref then " id=\"a" ^ ini_k ^ "\"" else "")
|
|
in
|
|
if not first then Output.print_sstring conf ",";
|
|
Output.print_sstring conf "\n<a";
|
|
Output.print_string conf href;
|
|
Output.print_string conf name;
|
|
Output.print_sstring conf ">";
|
|
Output.print_string conf
|
|
(particle_at_the_end base is_surnames s |> Util.escape_html);
|
|
Output.print_sstring conf "</a>";
|
|
Output.print_sstring conf " (";
|
|
Output.print_sstring conf (string_of_int cnt);
|
|
Output.print_sstring conf ")")
|
|
(List.sort (fun (a, _) (b, _) -> Gutil.alphabetic_order a b) l);
|
|
Output.print_sstring conf "</p>")
|
|
list;
|
|
Hutil.trailer conf
|
|
|
|
let print_short conf base is_surnames =
|
|
let ini = match p_getenv conf.env "k" with Some k -> k | _ -> "" in
|
|
let _ = if String.length ini < 2 then load_strings_array base in
|
|
match Alln.select_names conf base is_surnames ini max_int with
|
|
| Alln.Specify _, _ -> Hutil.incorrect_request conf
|
|
| Alln.Result list, len ->
|
|
let list = Alln.groupby_ini (Utf8.length ini + 1) list in
|
|
print_alphabetic_short conf base is_surnames ini list len
|
|
|
|
(* main *)
|
|
|
|
let print_surnames conf base =
|
|
match p_getenv conf.env "tri" with
|
|
| Some "F" -> print_frequency conf base true
|
|
| Some "S" -> print_short conf base true
|
|
| _ -> print_alphabetic conf base true
|
|
|
|
let print_first_names conf base =
|
|
match p_getenv conf.env "tri" with
|
|
| Some "F" -> print_frequency conf base false
|
|
| Some "S" -> print_short conf base false
|
|
| _ -> print_alphabetic conf base false
|