(* camlp5r ./pa_html.cmo *)
(* $Id: advSearchOk.ml,v 5.14 2007-09-12 09:58:44 ddr Exp $ *)
(* Copyright (c) 1998-2007 INRIA *)

open Config;
open Def;
open Gutil;
open Gwdb;
open Hutil;
open Util;

value get_number var key env = p_getint env (var ^ "_" ^ key);

value reconstitute_date_dmy conf var =
  match get_number var "yyyy" conf.env with
  [ Some y ->
      match get_number var "mm" conf.env with
      [ Some m ->
          match get_number var "dd" conf.env with
          [ Some d ->
              if d >= 1 && d <= 31 && m >= 1 && m <= 12 then
                Some {day = d; month = m; year = y; prec = Sure; delta = 0}
              else None
          | None ->
              if m >= 1 && m <= 12 then
                Some {day = 0; month = m; year = y; prec = Sure; delta = 0}
              else None ]
      | None -> Some {day = 0; month = 0; year = y; prec = Sure; delta = 0} ]
  | None -> None ]
;

value reconstitute_date conf var =
  match reconstitute_date_dmy conf var with
  [ Some d -> Some (Dgreg d Dgregorian)
  | None -> None ]
;

value name_eq x y = Name.abbrev (Name.lower x) = Name.abbrev (Name.lower y);

value rec skip_spaces x i =
  if i = String.length x then i
  else if String.unsafe_get x i = ' ' then skip_spaces x (i + 1)
  else i
;

value rec skip_no_spaces x i =
  if i = String.length x then i
  else if String.unsafe_get x i != ' ' then skip_no_spaces x (i + 1)
  else i
;

value string_incl x y =
  loop 0 where rec loop j_ini =
    if j_ini = String.length y then False
    else
      let rec loop1 i j =
        if i = String.length x then
          if j = String.length y then True else String.unsafe_get y j = ' '
        else if
          j < String.length y &&
          String.unsafe_get x i = String.unsafe_get y j then
          loop1 (i + 1) (j + 1)
        else loop (skip_spaces y (skip_no_spaces y j_ini))
      in
      loop1 0 j_ini
;

value name_incl x y =
  let x = Name.abbrev (Name.lower x) in
  let y = Name.abbrev (Name.lower y) in
  string_incl x y
;

value advanced_search conf base max_answers =
  let hs = Hashtbl.create 73 in
  let hd = Hashtbl.create 73 in
  let gets x =
    try Hashtbl.find hs x with
    [ Not_found ->
        let v =
          match p_getenv conf.env x with
          [ Some v -> v
          | None -> "" ]
        in
        do { Hashtbl.add hs x v; v } ]
  in
  let test x cmp =
    let y = gets x in
    if y = "" then True else cmp y
  in
  let test_auth p x cmp =
    let y = gets x in
    if y = "" then True else if fast_auth_age conf p then cmp y else False
  in
  let test_date p x df =
    let (d1, d2) =
      try Hashtbl.find hd x with
      [ Not_found ->
          let v =
            (reconstitute_date conf (x ^ "1"),
             reconstitute_date conf (x ^ "2"))
          in
          do { Hashtbl.add hd x v; v } ]
    in
    match (d1, d2) with
    [ (Some d1, Some d2) ->
        match df () with
        [ Some d when fast_auth_age conf p ->
            if CheckItem.strictly_before d d1 then False
            else if CheckItem.strictly_before d2 d then False
            else True
        | _ -> False ]
    | (Some d1, _) ->
        match df () with
        [ Some d when fast_auth_age conf p ->
            if CheckItem.strictly_before d d1 then False else True
        | _ -> False ]
    | (_, Some d2) ->
        match df () with
        [ Some d when fast_auth_age conf p ->
            if CheckItem.strictly_after d d2 then False else True
        | _ -> False ]
    | _ -> True ]
  in
  let list = ref [] in
  let len = ref 0 in
  let test_person p =
    if test "sex"
         (fun
          [ "M" -> get_sex p = Male
          | "F" -> get_sex p = Female
          | _ -> True ]) &&
       test_date p "birth" (fun () -> Adef.od_of_codate (get_birth p)) &&
       test_date p "bapt" (fun () -> Adef.od_of_codate (get_baptism p)) &&
       test_auth p "death"
         (fun d ->
            match (d, get_death p) with
            [ ("Dead", NotDead | DontKnowIfDead) -> False
            | ("Dead", _) -> True
            | ("NotDead", NotDead) -> True
            | ("NotDead", _) -> False
            | _ -> True ]) &&
       test_date p "death"
         (fun () ->
            match get_death p with
            [ Death _ cd -> Some (Adef.date_of_cdate cd)
            | _ -> None ]) &&
       test_date p "burial"
         (fun () ->
            match get_burial p with
            [ Buried cod -> Adef.od_of_codate cod
            | Cremated cod -> Adef.od_of_codate cod
            | _ -> None ]) &&
       test "first_name" (fun x -> name_eq x (p_first_name base p)) &&
       test "surname" (fun x -> name_eq x (p_surname base p)) &&
       test "married"
         (fun
          [ "Y" -> get_family p <> [| |]
          | "N" -> get_family p = [| |]
          | _ -> True ]) &&
       test_auth p "birth_place"
         (fun x -> name_incl x (sou base (get_birth_place p))) &&
       test_auth p "bapt_place"
         (fun x -> name_incl x (sou base (get_baptism_place p))) &&
       test_auth p "death_place"
         (fun x -> name_incl x (sou base (get_death_place p))) &&
       test_auth p "burial_place"
         (fun x -> name_incl x (sou base (get_burial_place p))) &&
       test_auth p "occu" (fun x -> name_incl x (sou base (get_occupation p)))
    then do {
      list.val := [p :: list.val]; incr len;
    }
    else ()
  in
  do {
    if gets "first_name" <> "" || gets "surname" <> "" then
      let (slist, _) =
        if gets "first_name" <> "" then
          Some.persons_of_fsname conf base base_strings_of_first_name
            (spi_find (persons_of_first_name base)) get_first_name
            (gets "first_name")
        else
          Some.persons_of_fsname conf base base_strings_of_surname
            (spi_find (persons_of_surname base)) get_surname
            (gets "surname")
      in
      let slist = List.fold_right (fun (_, _, l) sl -> l @ sl) slist [] in
      List.iter (fun ip -> test_person (pget conf base ip)) slist
    else
      for i = 0 to nb_of_persons base - 1 do {
        if len.val > max_answers then ()
        else test_person (pget conf base (Adef.iper_of_int i))
      };
    (List.rev list.val, len.val)
  }
;

value print_result conf base max_answers (list, len) =
  let list =
    if len > max_answers then
      Util.reduce_list max_answers list
    else list
  in
  if len = 0 then
    Wserver.wprint "%s\n" (capitale (transl conf "no match"))
  else
    (* Construction de la table des sosa de la base *)
    let () = Perso.build_sosa_ht conf base in 
    tag "ul" begin
      List.iter
        (fun p ->
           do {
             html_li conf;
             Perso.print_sosa conf base p True;
             Wserver.wprint "\n%s" (referenced_person_text conf base p);
             Wserver.wprint "%s" (Date.short_dates_text conf base p);
           })
        list;
      if len > max_answers then do { html_li conf; Wserver.wprint "...\n"; }
      else ();
    end
;

value print conf base =
  let title _ =
    Wserver.wprint "%s" (capitale (transl conf "advanced request"))
  in
  let max_answers =
    match p_getint conf.env "max" with
    [ Some n -> n
    | None -> 100 ]
  in
  do {
    header conf title;
    let list = advanced_search conf base max_answers in
    print_result conf base max_answers list;
    trailer conf;
  }
;
