1(* camlp4r *)
2(* $Id: nbdesc.ml,v 4.7 2007-10-28 06:57:31 deraugla Exp $ *)
3
4open Def;
5open Gwdb;
6open Printf;
7
8value designation base ip p =
9  let first_name = p_first_name base p in
10  let surname = p_surname base p in
11  if first_name = "?" || surname = "?" then
12    "i=" ^ string_of_int (Adef.int_of_iper ip)
13  else
14    Mutil.iso_8859_1_of_utf_8
15      (first_name ^ "." ^ string_of_int (get_occ p) ^ " " ^ surname)
16;
17
18value before_date d d1 =
19  if d1.year < d.year then True
20  else if d1.year > d.year then False
21  else if d1.month < d.month then True
22  else if d1.month > d.month then False
23  else if d1.prec > d.prec then True
24  else if d1.prec < d.prec then False
25  else if d1.day < d.day then True
26  else if d1.day > d.day then False
27  else True
28;
29
30value string_of_date d = string_of_int d.year;
31
32value apply base date nb_ind f = do {
33  let cnt = ref 0 in
34  for i = 0 to nb_ind - 1 do {
35    let ip = Adef.iper_of_int i in
36    let p = poi base ip in
37    match Adef.od_of_codate (get_birth p) with
38    [ Some (Dgreg b_dmy _) ->
39        let alive_at_that_date =
40          if before_date date b_dmy then
41            match get_death p with
42            [ Death _ cd ->
43                match Adef.date_of_cdate cd with
44                [ Dgreg d_dmy _ -> before_date d_dmy date
45                | _ -> False ]
46            | NotDead -> True
47            | _ -> False ]
48          else False
49        in
50        if alive_at_that_date then do {
51          f cnt.val ip p;
52          incr cnt
53        }
54        else ()
55    | Some (Dtext _) | None -> () ];
56  };
57  cnt.val
58};
59
60(**)
61value glop = ref 0;
62(**)
63
64value mark_cnt = ref 0;
65value number_of_desc base mark ip p = do {
66  incr mark_cnt;
67  let curr_mark = mark_cnt.val in
68  loop [] 0 [] (Array.to_list (get_family p))
69  where rec loop nb_list nb new_gen =
70    fun
71    [ [ifam :: ifaml] -> do {
72        let (nb, new_gen) =
73          if mark.(Adef.int_of_ifam ifam) = curr_mark then (nb, new_gen)
74          else do {
75            mark.(Adef.int_of_ifam ifam) := curr_mark;
76            let fam = foi base ifam in
77            let ipa = get_children fam in
78            let nb = nb + Array.length ipa in
79            let new_gen =
80              Array.fold_left
81                (fun ifaml ip ->
82                   let p = poi base ip in
83                   Array.to_list (get_family p) @ ifaml)
84                new_gen ipa
85            in
86            (nb, new_gen)
87          }
88        in
89        loop nb_list nb new_gen ifaml;
90      }
91    | [] ->
92         match new_gen with
93         [ [] -> List.rev nb_list
94         | _ ->
95(*
96let _ = do { if List.length nb_list > glop.val then do { glop.val := List.length nb_list; printf "\n%s gen %d" (designation base ip p) glop.val; flush stdout; } else () } in
97*)
98             loop [nb :: nb_list] 0 [] new_gen ] ]
99};
100
101value nb_desc bname date = do {
102  let base = Gwdb.open_base bname in
103  let () = Gwdb.load_descends_array base in
104  let () = Gwdb.load_unions_array base in
105  let nb_ind = nb_of_persons base in
106  let nb_fam = nb_of_families base in
107  let nb_liv = apply base date nb_ind (fun _ _ _ -> ()) in
108  printf "nombre de personnes vivantes en %s : %d\n" (string_of_date date)
109    nb_liv;
110  flush stdout;
111  let mark = Array.make nb_fam 0 in
112  let nb_desc = ref [] in
113  ProgrBar.start ();
114  ignore
115     (apply base date nb_ind
116        (fun cnt ip p -> do {
117           ProgrBar.run cnt nb_liv;
118           let nb_list = number_of_desc base mark ip p in
119           nb_desc.val :=
120             loop nb_desc.val nb_list where rec loop l1 l2 =
121               match (l1, l2) with
122               [ ([x1 :: l1], [x2 :: l2]) -> [x1+x2 :: loop l1 l2]
123               | (_, []) -> l1
124               | ([], _) -> l2 ];
125         }) :
126     int);
127  ProgrBar.finish ();
128  let (nb_gen, nb_tot) =
129    List.fold_left
130      (fun (nb_gen, nb_tot) nb_at_gen -> do {
131         printf "nombre moyen de descendants � la g�n�ration %2d :" nb_gen;
132         printf " %7.2f\n" (float nb_at_gen /. float nb_liv);
133         (nb_gen + 1, nb_tot + nb_at_gen)
134       })
135      (1, 0) nb_desc.val
136  in
137  printf "nombre de descendants moyen = %.2f\n"
138    (float nb_tot /. float nb_liv);
139  flush stdout;
140};
141
142value date year = {day = 0; month = 0; year = year; prec = Sure; delta = 0};
143
144value main () =
145  let bname = Sys.argv.(1) in
146  let year = int_of_string Sys.argv.(2) in
147  nb_desc bname (date year)
148;
149
150main ();
151