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