From afcccc5e7fbcf85e55b71707097d267858d6da57 Mon Sep 17 00:00:00 2001 From: ddr Date: Tue, 1 Sep 1998 14:32:19 +0000 Subject: [PATCH] Initial revision --- Makefile | 58 ++ ged2gwb/Makefile | 20 + ged2gwb/ansel.ml | 73 ++ ged2gwb/aurejac.ml | 146 ++++ ged2gwb/ged2gwb.ml | 1512 ++++++++++++++++++++++++++++++++++++++++ gwb2ged/Makefile | 20 + gwb2ged/gwb2ged.ml | 497 +++++++++++++ src/Makefile | 71 ++ src/adef.ml | 74 ++ src/adef.mli | 34 + src/advSearchOk.ml | 224 ++++++ src/alln.ml | 231 ++++++ src/argl.ml | 99 +++ src/ascend.ml | 880 +++++++++++++++++++++++ src/base64.ml | 85 +++ src/birth.ml | 87 +++ src/birthday.ml | 442 ++++++++++++ src/btree.ml | 118 ++++ src/check.ml | 247 +++++++ src/config.mli | 23 + src/consang.ml | 236 +++++++ src/date.ml | 150 ++++ src/def.mli | 133 ++++ src/def.syn.ml | 16 + src/descend.ml | 950 +++++++++++++++++++++++++ src/family.ml | 317 +++++++++ src/family.mli | 3 + src/gutil.ml | 714 +++++++++++++++++++ src/gutil.mli | 80 +++ src/gwc.ml | 554 +++++++++++++++ src/gwcomp.ml | 710 +++++++++++++++++++ src/gwd.ml | 654 +++++++++++++++++ src/gwu.ml | 605 ++++++++++++++++ src/i18n_check.ml | 31 + src/iobase.ml | 703 +++++++++++++++++++ src/iobase.mli | 10 + src/iovalue.ml | 233 +++++++ src/iovalue.mli | 31 + src/lock.ml | 38 + src/merge.ml | 76 ++ src/merge.mli | 8 + src/mergeFam.ml | 93 +++ src/mergeFamOk.ml | 123 ++++ src/mergeInd.ml | 279 ++++++++ src/mergeIndOk.ml | 193 +++++ src/mhashtbl.ml | 112 +++ src/mk_consang.ml | 47 ++ src/name.ml | 202 ++++++ src/name.mli | 31 + src/num.ml | 140 ++++ src/num.mli | 16 + src/pa_html.ml | 52 ++ src/pa_lock.ml | 18 + src/perso.ml | 628 +++++++++++++++++ src/phonygwd.ml | 74 ++ src/pqueue.ml | 56 ++ src/pqueue.mli | 32 + src/pr_transl.ml | 91 +++ src/q_codes.ml | 26 + src/relation.ml | 408 +++++++++++ src/relationLink.ml | 434 ++++++++++++ src/select.ml | 71 ++ src/some.ml | 443 ++++++++++++ src/srcfile.ml | 242 +++++++ src/srcfile.mli | 9 + src/title.ml | 399 +++++++++++ src/update.ml | 547 +++++++++++++++ src/update.mli | 30 + src/updateFam.ml | 450 ++++++++++++ src/updateFam.mli | 22 + src/updateFamOk.ml | 640 +++++++++++++++++ src/updateInd.ml | 684 ++++++++++++++++++ src/updateInd.mli | 14 + src/updateIndOk.ml | 529 ++++++++++++++ src/updateIndOk.mli | 15 + src/util.ml | 704 +++++++++++++++++++ src/util.mli | 79 +++ tools/Makefile.inc | 37 + tools/Makefile.inc.win | 43 ++ tools/camlp4_comm.sh | 27 + wserver/Makefile | 13 + wserver/wserver.ml | 526 ++++++++++++++ wserver/wserver.mli | 73 ++ 83 files changed, 19845 insertions(+) create mode 100644 Makefile create mode 100644 ged2gwb/Makefile create mode 100644 ged2gwb/ansel.ml create mode 100644 ged2gwb/aurejac.ml create mode 100644 ged2gwb/ged2gwb.ml create mode 100644 gwb2ged/Makefile create mode 100644 gwb2ged/gwb2ged.ml create mode 100644 src/Makefile create mode 100644 src/adef.ml create mode 100644 src/adef.mli create mode 100644 src/advSearchOk.ml create mode 100644 src/alln.ml create mode 100644 src/argl.ml create mode 100644 src/ascend.ml create mode 100644 src/base64.ml create mode 100644 src/birth.ml create mode 100644 src/birthday.ml create mode 100644 src/btree.ml create mode 100644 src/check.ml create mode 100644 src/config.mli create mode 100644 src/consang.ml create mode 100644 src/date.ml create mode 100644 src/def.mli create mode 100644 src/def.syn.ml create mode 100644 src/descend.ml create mode 100644 src/family.ml create mode 100644 src/family.mli create mode 100644 src/gutil.ml create mode 100644 src/gutil.mli create mode 100644 src/gwc.ml create mode 100644 src/gwcomp.ml create mode 100644 src/gwd.ml create mode 100644 src/gwu.ml create mode 100644 src/i18n_check.ml create mode 100644 src/iobase.ml create mode 100644 src/iobase.mli create mode 100644 src/iovalue.ml create mode 100644 src/iovalue.mli create mode 100644 src/lock.ml create mode 100644 src/merge.ml create mode 100644 src/merge.mli create mode 100644 src/mergeFam.ml create mode 100644 src/mergeFamOk.ml create mode 100644 src/mergeInd.ml create mode 100644 src/mergeIndOk.ml create mode 100644 src/mhashtbl.ml create mode 100644 src/mk_consang.ml create mode 100644 src/name.ml create mode 100644 src/name.mli create mode 100644 src/num.ml create mode 100644 src/num.mli create mode 100644 src/pa_html.ml create mode 100644 src/pa_lock.ml create mode 100644 src/perso.ml create mode 100644 src/phonygwd.ml create mode 100644 src/pqueue.ml create mode 100644 src/pqueue.mli create mode 100644 src/pr_transl.ml create mode 100644 src/q_codes.ml create mode 100644 src/relation.ml create mode 100644 src/relationLink.ml create mode 100644 src/select.ml create mode 100644 src/some.ml create mode 100644 src/srcfile.ml create mode 100644 src/srcfile.mli create mode 100644 src/title.ml create mode 100644 src/update.ml create mode 100644 src/update.mli create mode 100644 src/updateFam.ml create mode 100644 src/updateFam.mli create mode 100644 src/updateFamOk.ml create mode 100644 src/updateInd.ml create mode 100644 src/updateInd.mli create mode 100644 src/updateIndOk.ml create mode 100644 src/updateIndOk.mli create mode 100644 src/util.ml create mode 100644 src/util.mli create mode 100644 tools/Makefile.inc create mode 100644 tools/Makefile.inc.win create mode 100644 tools/camlp4_comm.sh create mode 100644 wserver/Makefile create mode 100644 wserver/wserver.ml create mode 100644 wserver/wserver.mli diff --git a/Makefile b/Makefile new file mode 100644 index 0000000000..680a3a3a2c --- /dev/null +++ b/Makefile @@ -0,0 +1,58 @@ +# $Id: Makefile,v 1.1 1998-09-01 14:32:01 ddr Exp $ + +include tools/Makefile.inc + +all:: out + +out:: + cd wserver; $(MAKE) all + cd src; $(MAKE) all + cd ged2gwb; $(MAKE) all + cd gwb2ged; $(MAKE) all + +opt:: + cd wserver; $(MAKE) opt + cd src; $(MAKE) opt + cd ged2gwb; $(MAKE) opt + cd gwb2ged; $(MAKE) opt + +distrib: + $(RM) -rf distribution + mkdir distribution + cp CHANGES LICENCE distribution/. + cp src/gwc.opt distribution/gwc$(EXE) + cp src/consang.opt distribution/consang$(EXE) + cp src/lgwd distribution/gwd$(EXE) + cp src/gwu.opt distribution/gwu$(EXE) + cp ged2gwb/ged2gwb.opt distribution/ged2gwb$(EXE) + cp gwb2ged/gwb2ged.opt distribution/gwb2ged$(EXE) + cp etc/ALIRE.txt distribution/. + cp etc/README.txt distribution/. + mkdir distribution/doc + cp doc/index.htm distribution/doc/. + mkdir distribution/doc/fr distribution/doc/en + cp doc/fr/*.htm distribution/doc/fr/. + cp doc/en/*.htm distribution/doc/en/. + mkdir distribution/lang + cp etc/a.cnf distribution/. + cp hd/lang/*.txt distribution/lang/. + for dir in de en eo es fr it nl se; do \ + mkdir distribution/lang/$$dir; \ + cp hd/lang/$$dir/start.txt distribution/lang/$$dir/.; \ + done + mkdir distribution/images + cp hd/images/up.gif distribution/images/. + +clean:: + cd wserver; $(MAKE) clean + cd src; $(MAKE) clean + cd ged2gwb; $(MAKE) clean + cd gwb2ged; $(MAKE) clean + $(RM) -rf distribution + $(RM) -f *~ .#* + +depend: + cd wserver; $(MAKE) depend + cd src; $(MAKE) depend + cd ged2gwb; $(MAKE) depend + cd gwb2ged; $(MAKE) depend diff --git a/ged2gwb/Makefile b/ged2gwb/Makefile new file mode 100644 index 0000000000..353e27b171 --- /dev/null +++ b/ged2gwb/Makefile @@ -0,0 +1,20 @@ +# $Id: Makefile,v 1.1 1998-09-01 14:32:12 ddr Exp $ + +include ../tools/Makefile.inc + +OCAMLI=-I ../src +OBJS=../src/argl.cmo ../src/adef.cmo ../src/iovalue.cmo ../src/name.cmo ../src/gutil.cmo ../src/btree.cmo ../src/iobase.cmo aurejac.cmo ansel.cmo ged2gwb.cmo + +all:: ged2gwb.out +opt:: ged2gwb.opt + +ged2gwb.out: $(OBJS) + $(OCAMLC) -custom unix.cma $(LIBUNIX) $(CAMLP4D)/gramlib.cma $(OBJS) -o ged2gwb.out + +ged2gwb.opt: $(OBJS:.cmo=.cmx) + $(OCAMLOPT) unix.cmxa $(LIBUNIX) $(CAMLP4D)/gramlib.cmxa $(OBJS:.cmo=.cmx) -o ged2gwb.opt + +depend: + ocamldep $(OCAMLI) *.ml* > .depend + +include .depend diff --git a/ged2gwb/ansel.ml b/ged2gwb/ansel.ml new file mode 100644 index 0000000000..92a3000fd2 --- /dev/null +++ b/ged2gwb/ansel.ml @@ -0,0 +1,73 @@ +(* $Id: ansel.ml,v 1.1 1998-09-01 14:32:13 ddr Exp $ *) + +value acute = + fun + [ 'a' -> 'á' + | 'e' -> 'é' + | 'i' -> 'í' + | 'E' -> 'É' + | x -> x ] +; + +value grave = + fun + [ 'a' -> 'à' + | 'e' -> 'è' + | 'u' -> 'ù' + | x -> x ] +; + +value circ = + fun + [ 'a' -> 'â' + | 'e' -> 'ê' + | 'i' -> 'î' + | 'o' -> 'ô' + | x -> x ] +; + +value uml = + fun + [ 'a' -> 'ä' + | 'e' -> 'ë' + | 'i' -> 'ï' + | 'o' -> 'ö' + | 'O' -> 'Ö' + | x -> x ] +; + +value cedil = + fun + [ 'c' -> 'ç' + | x -> x ] +; + +value translate s = + let len = + loop 0 0 where rec loop i len = + if i == String.length s then len + else if i == String.length s - 1 then len + 1 + else + match Char.code s.[i] with + [ 225 | 226 | 227 | 232 | 240 -> loop (i + 1) len + | _ -> loop (i + 1) (len + 1) ] + in + if len == String.length s then s + else + let s' = String.create len in + loop 0 0 where rec loop i i' = + if i == String.length s then s' + else if i == String.length s - 1 then + do s'.[i'] := s.[i]; return s' + else + let i = + match Char.code s.[i] with + [ 225 -> do s'.[i'] := grave s.[i+1]; return i + 1 + | 226 -> do s'.[i'] := acute s.[i+1]; return i + 1 + | 227 -> do s'.[i'] := circ s.[i+1]; return i + 1 + | 232 -> do s'.[i'] := uml s.[i+1]; return i + 1 + | 240 -> do s'.[i'] := cedil s.[i+1]; return i + 1 + | _ -> do s'.[i'] := s.[i]; return i ] + in + loop (i + 1) (i' + 1) +; diff --git a/ged2gwb/aurejac.ml b/ged2gwb/aurejac.ml new file mode 100644 index 0000000000..2377baf6a0 --- /dev/null +++ b/ged2gwb/aurejac.ml @@ -0,0 +1,146 @@ +(* $Id: aurejac.ml,v 1.1 1998-09-01 14:32:12 ddr Exp $ *) +(* Find titles had hoc for genealogy Aurejac *) + +value trace = False; + +value rec s_skip_spaces s i = + if i == String.length s then i + else if s.[i] = ' ' then s_skip_spaces s (i + 1) + else i +; +value string_sub_unless_dot s ibeg i = + if i > ibeg + 1 && s.[i - 1] = '.' then + (String.sub s ibeg (i - ibeg - 1), i - 1) + else (String.sub s ibeg (i - ibeg), i) +; + +value rec s_ident s ibeg i = + if i == String.length s then + if i == ibeg then raise Not_found + else string_sub_unless_dot s ibeg i + else + match s.[i] with + [ 'a'..'z' | 'A'..'Z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '-' | '.' -> + s_ident s ibeg (i + 1) + | ''' -> (String.sub s ibeg (i + 1 - ibeg), i + 1) + | _ -> + if i == ibeg then raise Not_found + else string_sub_unless_dot s ibeg i ] +; +value rec s_skip_opt_nth s ibeg i = + if i == String.length s then + if i == ibeg then i else raise Not_found + else + match s.[i] with + [ '0'..'9' -> s_skip_opt_nth s ibeg (i + 1) + | _ -> + if i == ibeg then i + else + let (id, i1) = s_ident s i i in + match id with + [ "er" | "ème" -> i1 + | _ -> raise Not_found ] ] +; +value s_complement s i id = + match id with + [ "de" | "des" | "d'" | "en" | "du" -> + let i = s_skip_spaces s i in + let (id2, i) = s_ident s i i in + let (particle, complement, i) = + if id = "de" then + match id2 with + [ "la" | "La" | "l'" | "L'" -> + let i = s_skip_spaces s i in + let (complement, i) = s_ident s i i in + ("de " ^ id2, complement, i) + | _ -> (id, id2, i) ] + else (id, id2, i) + in + match complement.[0] with + [ 'A'..'Z' | 'À'..'Ö' -> + let complement = + if particle.[String.length particle - 1] = ''' then + particle ^ complement + else particle ^ " " ^ complement + in + let (complement, i) = + if complement.[String.length complement - 1] = ''' then + let (id, i) = s_ident s i i in + (complement ^ id, i) + else (complement, i) + in + (complement, i) + | _ -> raise Not_found ] + | _ -> raise Not_found ] +; + +value try_find_title s i = + let i = s_skip_spaces s i in + let i = s_skip_opt_nth s i i in + let i = s_skip_spaces s i in + let (title, i) = + let (title, i) = s_ident s i i in + if title = "premier" || title = "Premier" then + let i = s_skip_spaces s i in + s_ident s i i + else (title, i) + in + let i = s_skip_spaces s i in + let (title, id, i) = + let (cotitle, i) = s_ident s i i in + match cotitle with + [ "de" | "des" | "d'" | "en" | "du" -> (title, cotitle, i) + | _ -> + match cotitle.[0] with + [ 'A'..'Z' | 'À'..'Ö' -> + let i = s_skip_spaces s i in + let (id, i) = s_ident s i i in + (title ^ " " ^ cotitle, id, i) + | _ -> raise Not_found ] ] + in + let (place, i) = s_complement s i id in + let (place, i) = + try + let i = s_skip_spaces s i in + let (id, i) = s_ident s i i in + let (comp, i) = s_complement s i id in + (place ^ " " ^ comp, i) + with [ Not_found -> (place, i) ] + in + let title = String.uncapitalize title in + do if trace then + do Printf.printf "%s : %s\n" title place; flush stdout; return () + else (); + return + (title, place) +; + +value start_id = + ["Profession"; "Abbesse"; "Châtelaine"; "Comtesse"; "Dame"; "Héritière"; + "Reine"; "Vicomtesse"] +; + +value find_titles s = + match try Some (s_ident s 0 0) with [ Not_found -> None ] with + [ Some (id, i) when List.mem id start_id -> + do if trace then do Printf.printf " %s\n" s; flush stdout; return () + else (); + return + let i = s_skip_spaces s i in + let i = + if id = "Profession" then + if i < String.length s && s.[i] == ':' then s_skip_spaces s (i + 1) + else i + else 0 + in + try [try_find_title s i] with + [ Not_found -> + try + let i = String.index s ',' + 1 in + [try_find_title s i] + with + [ Not_found -> + if trace then do Printf.printf "failed\n"; flush stdout; return [] + else [] ] ] + | _ -> [] ] +; diff --git a/ged2gwb/ged2gwb.ml b/ged2gwb/ged2gwb.ml new file mode 100644 index 0000000000..1c21e90b63 --- /dev/null +++ b/ged2gwb/ged2gwb.ml @@ -0,0 +1,1512 @@ +(* camlp4r pa_extend.cmo *) +(* $Id: ged2gwb.ml,v 1.1 1998-09-01 14:32:13 ddr Exp $ *) + +open Def; +open Gutil; + +type record = + { rlab : string; + rval : string; + rcont : string; + rsons : list record } +; + +value titles_aurejac = ref False; +value lowercase_first_names = ref False; +value lowercase_surnames = ref False; +value extract_first_names = ref True; +value extract_public_names = ref True; +value ansel_option = ref None; +value ansel_characters = ref True; +value try_negative_dates = ref False; + +(* Reading input *) + +value buff = ref (String.create 80); +value store len x = + do if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + return succ len +; +value get_buff len = String.sub buff.val 0 len; + +value rec skip_eol = + parser + [ [: `'\n' | '\r'; _ = skip_eol :] -> () + | [: :] -> () ] +; + +value rec get_to_eoln len = + parser + [ [: `'\n' | '\r'; _ = skip_eol :] -> get_buff len + | [: `c; s :] -> get_to_eoln (store len c) s ] +; + +value rec get_ident len = + parser + [ [: `' ' :] -> get_buff len + | [: `c when not (List.mem c ['\n'; '\r']); s :] -> + get_ident (store len c) s + | [: :] -> get_buff len ] +; + +value rec get_lev n = + parser + [ [: `c when c == n; `' ' ? "space"; r1 = get_ident 0; r2 = get_ident 0; + r3 = get_to_eoln 0 ? "get to eoln"; + l = get_lev_list [] (Char.chr (Char.code n + 1)) ? "get lev list" :] -> + let (rlab, rval, rcont) = + if r1.[0] = '@' then (r2, r1, r3) + else + let rval = if r3 = "" then r2 else r2 ^ " " ^ r3 in + (r1, rval, "") + in + {rlab = rlab; + rval = + if ansel_characters.val then Ansel.translate rval + else rval; + rcont = + if ansel_characters.val then Ansel.translate rcont + else rcont; + rsons = List.rev l} ] +and get_lev_list l n = + parser + [ [: x = get_lev n; s :] -> get_lev_list [x :: l] n s + | [: :] -> l ] +; + +(* Decoding fields *) + +value rec skip_spaces = + parser + [ [: `' '; s :] -> skip_spaces s + | [: :] -> () ] +; + +value rec ident_slash len = + parser + [ [: `'/' :] -> get_buff len + | [: `c; i = ident_slash (store len c) :] -> i + | [: :] -> get_buff len ] +; + +value strip c str = + let start = loop 0 + where rec loop i = + if i == String.length str then i + else if str.[i] == c then loop (i + 1) + else i + in + let stop = loop (String.length str - 1) + where rec loop i = + if i == -1 then i + 1 + else if str.[i] == c then loop (i - 1) + else i + 1 + in + if start == 0 && stop == String.length str then str + else if start >= stop then "" + else String.sub str start (stop - start) +; + +value strip_spaces = strip ' '; +value strip_newlines = strip '\n'; + +value less_greater_escaped s = + let rec need_code i = + if i < String.length s then + match s.[i] with + [ '<' | '>' -> True + | x -> need_code (succ i) ] + else False + in + let rec compute_len i i1 = + if i < String.length s then + let i1 = + match s.[i] with + [ '<' | '>' -> i1 + 4 + | _ -> succ i1 ] + in + compute_len (succ i) i1 + else i1 + in + let rec copy_code_in s1 i i1 = + if i < String.length s then + let i1 = + match s.[i] with + [ '<' -> do String.blit "<" 0 s1 i1 4; return i1 + 4 + | '>' -> do String.blit ">" 0 s1 i1 4; return i1 + 4 + | c -> do s1.[i1] := c; return succ i1 ] + in + copy_code_in s1 (succ i) i1 + else s1 + in + if need_code 0 then + let len = compute_len 0 0 in copy_code_in (String.create len) 0 0 + else s +; + +value parse_name = + parser + [ [: _ = skip_spaces; + invert = parser [ [: `'/' :] -> True | [: :] -> False ]; + f = ident_slash 0; _ = skip_spaces; s = ident_slash 0 :] -> + let (f, s) = if invert then (s, f) else (f, s) in + let f = strip_spaces f in + let s = strip_spaces s in + (if f = "" then "x" else f, if s = "" then "?" else s) ] +; + +value rec find_field lab = + fun + [ [r :: rl] -> if r.rlab = lab then Some r else find_field lab rl + | [] -> None ] +; + +value rec find_all_fields lab = + fun + [ [r :: rl] -> + if r.rlab = lab then [r :: find_all_fields lab rl] + else find_all_fields lab rl + | [] -> [] ] +; + +value rec lexing = + parser + [ [: `('0'..'9' as c); n = number (store 0 c) :] -> Token.Tint n + | [: `('A'..'Z' as c); i = ident (store 0 c) :] -> Token.Tlident i + | [: `'.' :] -> Token.Tterm "." + | [: `' ' | '\r'; s :] -> lexing s + | [: _ = Stream.empty :] -> Token.Teoi + | [: `x :] -> Token.Tterm (String.make 1 x) ] +and number len = + parser + [ [: `('0'..'9' as c); n = number (store len c) :] -> n + | [: :] -> get_buff len ] +and ident len = + parser + [ [: `('A'..'Z' as c); n = ident (store len c) :] -> n + | [: :] -> get_buff len ] +; + +value make_lexing s = Stream.from (fun _ -> Some (lexing s)); + +value lexer = + {Token.func = fun s -> (make_lexing s, fun _ -> (0, 0)); + Token.add_keyword = fun _ -> (); + Token.remove_keyword = fun _ -> (); + Token.text = fun _ -> ""} +; + +type title_date 'a = [ TDinterv of 'a and 'a | TDstart of 'a | TDend of 'a ]; + +value g = Grammar.create lexer; +value date = Grammar.Entry.create g "date"; +value title_date = Grammar.Entry.create g "title_date"; +value find_year = + let rec find strm = + match strm with parser + [ [: `Token.Tint n :] -> + let n = int_of_string n in + if n >= 32 && n <= 2500 then n else find strm + | [: `Token.Teoi :] -> raise Not_found + | [: `_ :] -> find strm ] + in + Grammar.Entry.of_parser g "find_year" find +; +EXTEND + GLOBAL: date title_date; + date: + [[ p = prec; (n1, n2, n3) = simple_date; EOI -> (p, n1, n2, n3) ]]; + simple_date: + [[ LIST0 "."; n1 = OPT int; LIST0 "."; + n2 = OPT [ i = int -> i | m = month -> m ]; LIST0 "."; + n3 = OPT int; LIST0 "." -> (n1, n2, n3) ]]; + title_date: + [[ LIDENT "BET"; _ = prec; d1 = simple_date; + LIDENT "AND"; _ = prec; d2 = simple_date -> + TDinterv d1 d2 + | LIDENT "BEF"; d = simple_date -> TDend d + | _ = prec; d = simple_date -> TDstart d ]]; + prec: + [[ LIDENT "ABT" -> About | LIDENT "ENV" -> About + | LIDENT "BEF" -> Before | LIDENT "AFT" -> After + | LIDENT "EST" -> Maybe | -> Sure ]]; + month: + [[ LIDENT "JAN" -> 1 | LIDENT "FEB" -> 2 | LIDENT "MAR" -> 3 + | LIDENT "APR" -> 4 | LIDENT "MAY" -> 5 | LIDENT "JUN" -> 6 + | LIDENT "JUL" -> 7 | LIDENT "AUG" -> 8 | LIDENT "SEP" -> 9 + | LIDENT "OCT" -> 10 | LIDENT "NOV" -> 11 | LIDENT "DEC" -> 12 ]]; + int: + [[ i = INT -> int_of_string i + | "-"; i = INT -> - int_of_string i ]]; +END; + +value date_of_field d = + if d = "" then None + else + let s = Stream.of_string (String.uppercase d) in + let r = + try Some (Grammar.Entry.parse date s) with + [ Stdpp.Exc_located loc e -> None ] + in + match r with + [ Some (Sure, Some d, Some m, Some y) -> Some (Djma d m y) + | Some (p, Some d, Some m, Some y) -> Some (Da About y) + | Some (Sure, None, Some m, Some y) -> Some (Dma m y) + | Some (p, None, Some m, Some y) -> Some (Da About y) + | Some (p, None, None, Some y) -> Some (Da p y) + | Some (p, Some y, None, None) -> Some (Da p y) + | _ -> + try + Some (Da Maybe (Grammar.Entry.parse find_year (Stream.of_string d))) + with + [ Stdpp.Exc_located loc e -> + do Printf.printf "Can't decode date %s\n" d; + flush stdout; + return None ] ] +; + +(* Creating base *) + +type choice 'a 'b = [ Left of 'a | Right of 'b ]; +type tab 'a = {arr : mutable array 'a; tlen : mutable int}; + +type gen = + {g_per : tab (choice string base_person); + g_asc : tab (choice string base_ascend); + g_fam : tab (choice string base_family); + g_cpl : tab (choice string base_couple); + g_str : tab string; + g_hper : Hashtbl.t string Adef.iper; + g_hfam : Hashtbl.t string Adef.ifam; + g_hstr : Hashtbl.t string Adef.istr; + g_hnot : Hashtbl.t string record; + g_hnam : Hashtbl.t string (ref int); +(* + g_all : Hashtbl.t string unit; +*) + g_fnot : mutable list (iper * list record)} +; + +value assume_tab name tab none = + if tab.tlen == Array.length tab.arr then + let new_len = 2 * Array.length tab.arr + 1 in + let new_arr = Array.create new_len none in + do Array.blit tab.arr 0 new_arr 0 (Array.length tab.arr); + tab.arr := new_arr; + return () + else () +; + +value add_string gen s = + try Hashtbl.find gen.g_hstr s with + [ Not_found -> + let i = gen.g_str.tlen in + do assume_tab "gen.g_str" gen.g_str ""; + gen.g_str.arr.(i) := s; + gen.g_str.tlen := gen.g_str.tlen + 1; + Hashtbl.add gen.g_hstr s (Adef.istr_of_int i); + return + Adef.istr_of_int i ] +; + +value per_index gen lab = + try Hashtbl.find gen.g_hper lab with + [ Not_found -> + let i = gen.g_per.tlen in + do assume_tab "gen.g_per" gen.g_per (Left ""); + gen.g_per.arr.(i) := Left lab; + gen.g_per.tlen := gen.g_per.tlen + 1; + assume_tab "gen.g_asc" gen.g_asc (Left ""); + gen.g_asc.arr.(i) := Left lab; + gen.g_asc.tlen := gen.g_asc.tlen + 1; + Hashtbl.add gen.g_hper lab (Adef.iper_of_int i); + return Adef.iper_of_int i ] +; + +value fam_index gen lab = + try Hashtbl.find gen.g_hfam lab with + [ Not_found -> + let i = gen.g_fam.tlen in + do assume_tab "gen.g_fam" gen.g_fam (Left ""); + gen.g_fam.arr.(i) := Left lab; + gen.g_fam.tlen := gen.g_fam.tlen + 1; + assume_tab "gen.g_cpl" gen.g_cpl (Left ""); + gen.g_cpl.arr.(i) := Left lab; + gen.g_cpl.tlen := gen.g_cpl.tlen + 1; + Hashtbl.add gen.g_hfam lab (Adef.ifam_of_int i); + return Adef.ifam_of_int i ] +; + +value unknown_per gen i = + let empty = add_string gen "" in + let what = add_string gen "?" in + let p = + {first_name = what; + surname = what; + occ = i; + public_name = empty; + photo = empty; + nick_names = []; aliases = []; first_names_aliases = []; + surnames_aliases = []; + titles = []; occupation = empty; + sexe = Neutre; access = IfTitles; + birth = Adef.codate_None; birth_place = empty; + baptism = Adef.codate_None; baptism_place = empty; + death = DontKnowIfDead; death_place = empty; + burial = UnknownBurial; burial_place = empty; + family = [| |]; + notes = empty; + psources = empty; + cle_index = Adef.iper_of_int i} + and a = + {parents = None; + consang = Adef.fix (-1)} + in + (p, a) +; + +value phony_per gen = + let i = gen.g_per.tlen in + let (person, ascend) = unknown_per gen i in + do assume_tab "gen.g_per" gen.g_per (Left ""); + gen.g_per.tlen := gen.g_per.tlen + 1; + gen.g_per.arr.(i) := Right person; + assume_tab "gen.g_asc" gen.g_asc (Left ""); + gen.g_asc.arr.(i) := Right ascend; + gen.g_asc.tlen := gen.g_asc.tlen + 1; + return Adef.iper_of_int i +; + +value this_year = 1998; + +(* +value exists gen x = + try do Hashtbl.find gen.g_all x; return True with [ Not_found -> False ] +; +*) + +value make_title gen (title, place) = + {t_name = Tnone; + t_title = add_string gen title; + t_place = add_string gen place; + t_date_start = Adef.codate_None; + t_date_end = Adef.codate_None; + t_nth = 0} +; + +value string_ini_eq s1 i s2 = + loop i 0 where rec loop i j = + if j == String.length s2 then True + else if i == String.length s1 then False + else if s1.[i] == s2.[j] then loop (i + 1) (j + 1) + else False +; + +value particle s i = + string_ini_eq s i "des " || string_ini_eq s i "DES " || + string_ini_eq s i "de " || string_ini_eq s i "DE " || + string_ini_eq s i "du " || string_ini_eq s i "DU " || + string_ini_eq s i "d'" || string_ini_eq s i "D'" +; + +value lowercase_name s = + loop (particle s 0) 0 where rec loop uncap i = + if i == String.length s then s + else + let c = s.[i] in + let (c, uncap) = + match c with + [ 'a'..'z' | 'á'..'ý' -> + (if uncap then c + else Char.chr (Char.code c - Char.code 'a' + Char.code 'A'), + True) + | 'A'..'Z' | 'À'.. 'Ý' -> + (if not uncap then c + else Char.chr (Char.code c - Char.code 'A' + Char.code 'a'), + True) + | c -> (c, particle s (i + 1)) ] + in + do s.[i] := c; return loop uncap (i + 1) +; + +value add_sour gen r l = + match find_field "SOUR" r.rsons with + [ Some r -> + if String.length r.rval > 0 && r.rval.[0] = '@' then l + else if List.mem r.rval l then l else [r.rval :: l] + | _ -> l ] +; + +value look_like_a_number s = + loop 0 where rec loop i = + if i == String.length s then True + else + match s.[i] with + [ '0'..'9' -> loop (i + 1) + | _ -> False ] +; + +value look_like_a_roman_number s = + loop 0 where rec loop i = + if i == String.length s then True + else + match s.[i] with + [ 'I' | 'V' | 'X' | 'L' -> loop (i + 1) + | _ -> False ] +; + +value is_a_name_char = + fun + [ 'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' | '-' + | ''' -> True + | _ -> False ] +; + +value rec next_word_pos s i = + if i == String.length s then i + else if is_a_name_char s.[i] then i + else next_word_pos s (i + 1) +; + +value rec next_sep_pos s i = + if i == String.length s then String.length s + else if is_a_name_char s.[i] then next_sep_pos s (i + 1) + else i +; + +value public_name_word = + ["Ier"; "Ière"; "der"; "die"; "el"; "le"; "la"; "the"] +; + +value rec is_a_public_name s i = + let i = next_word_pos s i in + if i == String.length s then False + else + let j = next_sep_pos s i in + if j > i then + let w = String.sub s i (j - i) in + if look_like_a_number w then True + else if look_like_a_roman_number w then True + else if List.mem w public_name_word then True + else is_a_public_name s j + else False +; + +value extract_notes gen rl nf = + List.fold_right + (fun r lines -> + List.fold_right + (fun r lines -> + if r.rlab = "NOTE" && r.rval <> "" && r.rval.[0] == '@' + then + let (r, lab) = + try (Hashtbl.find gen.g_hnot r.rval, "NOTE") with + [ Not_found -> + ({rlab = ""; rval = ""; rcont = nf r.rval; rsons = []}, + "") ] + in + let l = List.map (fun r -> (r.rlab, r.rval)) r.rsons in + [(lab, r.rcont) :: l @ lines] + else [(r.rlab, r.rval) :: lines]) + [r :: r.rsons] lines) + rl [] +; + +value treat_indi_notes_titles gen rl nf = + let lines = extract_notes gen rl nf in + let (notes, titles) = + List.fold_left + (fun (s, titles) (lab, n) -> + let n = strip_spaces n in + let titles = titles @ Aurejac.find_titles n in + let s = + if s = "" then n + else if lab = "CONT" || lab = "NOTE" then s ^ "
\n" ^ n + else if n = "" then s + else s ^ "\n" ^ n + in + (s, titles)) + ("", []) lines + in + let titles = List.map (make_title gen) titles in + (add_string gen (strip_newlines notes), titles) +; + +value treat_indi_notes gen rl nf = + let lines = extract_notes gen rl nf in + let notes = + List.fold_left + (fun s (lab, n) -> + let n = strip_spaces n in + if s = "" then n + else if lab = "CONT" || lab = "NOTE" then s ^ "
\n" ^ n + else if n = "" then s + else s ^ "\n" ^ n) + "" lines + in + add_string gen (strip_newlines notes) +; + +value string_empty = ref (Adef.istr_of_int 0); +value string_x = ref (Adef.istr_of_int 0); + +value p_index_from s i c = + if i >= String.length s then String.length s + else + try String.index_from s i c with + [ Not_found -> String.length s ] +; + +value strip_sub s beg len = + strip_spaces (String.sub s beg len) +; + +value decode_title s = + let i1 = p_index_from s 0 ',' in + let i2 = p_index_from s (i1 + 1) ',' in + let title = strip_sub s 0 i1 in + let (place, nth) = + if i1 == String.length s then ("", 0) + else if i2 == String.length s then + let s1 = strip_sub s (i1 + 1) (i2 - i1 - 1) in + try ("", int_of_string s1) with + [ Failure _ -> (s1, 0) ] + else + let s1 = strip_sub s (i1 + 1) (i2 - i1 - 1) in + let s2 = strip_sub s (i2 + 1) (String.length s - i2 - 1) in + try (s1, int_of_string s2) with + [ Failure _ -> + (strip_sub s i1 (String.length s - i1), 0) ] + in + (title, place, nth) +; + +value date_of_sd = + fun + [ (Some d, Some m, Some y) -> Djma d m y + | (None, Some m, Some y) -> Dma m y + | (None, None, Some y) -> Da Sure y + | (Some y, None, None) -> Da Sure y + | _ -> raise Not_found ] +; + +value decode_date_interval s = + let strm = Stream.of_string s in + try + match Grammar.Entry.parse title_date strm with + [ TDinterv d1 d2 -> (Some (date_of_sd d1), Some (date_of_sd d2)) + | TDstart d1 -> (Some (date_of_sd d1), None) + | TDend d2 -> (None, Some (date_of_sd d2)) ] + with + [ Stdpp.Exc_located _ _ | Not_found -> + do Printf.printf "Can't decode date %s\n" s; + flush stdout; + return (None, None) ] +; + +value treat_indi_title gen public_name r = + let (title, place, nth) = decode_title r.rval in + let (date_start, date_end) = + match find_field "DATE" r.rsons with + [ Some r -> decode_date_interval r.rval + | None -> (None, None) ] + in + let name = + match find_field "NOTE" r.rsons with + [ Some r -> + if r.rval = public_name then Tmain + else Tname (add_string gen (strip_spaces r.rval)) + | None -> Tnone ] + in + {t_name = name; t_title = add_string gen title; + t_place = add_string gen place; + t_date_start = Adef.codate_of_od date_start; + t_date_end = Adef.codate_of_od date_end; + t_nth = nth} +; + +value add_indi gen r = + let i = per_index gen r.rval in + let (first_name, surname, occ, public_name, nick_name, first_name_alias) = + match find_field "NAME" r.rsons with + [ Some n -> + let (f, s) = parse_name (Stream.of_string n.rval) in + let (f, pn, fa) = + if extract_public_names.val || extract_first_names.val then + let i = next_word_pos f 0 in + let j = next_sep_pos f i in + if j == String.length f then (f, "", "") + else + let fn = String.sub f i (j - i) in + if extract_public_names.val then + if is_a_public_name f j then (fn, f, "") + else if extract_first_names.val then (fn, "", f) + else (f, "", "") + else (fn, "", f) + else (f, "", "") + in + let f = if lowercase_first_names.val then lowercase_name f else f in + let fa = if lowercase_first_names.val then lowercase_name fa else fa in + let s = if lowercase_surnames.val then lowercase_name s else s in + let r = + let key = Name.strip_lower (f ^ " " ^ s) in + try Hashtbl.find gen.g_hnam key with + [ Not_found -> + let r = ref (-1) in + do Hashtbl.add gen.g_hnam key r; return r ] + in + let nn = + match find_field "NICK" n.rsons with + [ Some r -> r.rval + | None -> "" ] + in + do incr r; return (f, s, r.val, pn, nn, fa) + | None -> ("?", "?", Adef.int_of_iper i, "", "", "") ] + in + let sex = + match find_field "SEX" r.rsons with + [ Some {rval = "M"} -> Masculin + | Some {rval = "F"} -> Feminin + | _ -> Neutre ] + in + let parents = + match find_field "FAMC" r.rsons with + [ Some r -> Some (fam_index gen r.rval) + | None -> None ] + in + let occupation = + match find_all_fields "OCCU" r.rsons with + [ [r :: rl] -> List.fold_left (fun s r -> s ^ ", " ^ r.rval) r.rval rl + | [] -> "" ] + in + let (notes, titles) = + if titles_aurejac.val then + match find_all_fields "NOTE" r.rsons with + [ [] -> (string_empty.val, []) + | rl -> + try treat_indi_notes_titles gen rl (fun _ -> raise Not_found) with + [ Not_found -> + do gen.g_fnot := [(i, rl) :: gen.g_fnot]; return + (string_empty.val, []) ] ] + else + let notes = + match find_all_fields "NOTE" r.rsons with + [ [] -> string_empty.val + | rl -> + try treat_indi_notes gen rl (fun _ -> raise Not_found) with + [ Not_found -> + do gen.g_fnot := [(i, rl) :: gen.g_fnot]; return + string_empty.val ] ] + in + (notes, []) + in + let titles = + if titles_aurejac.val then titles + else + List.map (treat_indi_title gen public_name) + (find_all_fields "TITL" r.rsons) + in + let family = + let rl = find_all_fields "FAMS" r.rsons in +(* + let rl = + List.fold_right (fun r rl -> if exists gen r.rval then [r :: rl] else rl) + rl [] + in +*) + List.map (fun r -> fam_index gen r.rval) rl + in + let (birth, birth_place) = + match find_field "BIRT" r.rsons with + [ Some r -> + let d = + match find_field "DATE" r.rsons with + [ Some r -> date_of_field r.rval + | _ -> None ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (d, p) + | None -> (None, "") ] + in + let (bapt, bapt_place) = + let ro = + match find_field "BAPM" r.rsons with + [ None -> find_field "CHR" r.rsons + | x -> x ] + in + match ro with + [ Some r -> + let d = + match find_field "DATE" r.rsons with + [ Some r -> date_of_field r.rval + | _ -> None ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (Adef.codate_of_od d, p) + | None -> (Adef.codate_None, "") ] + in + let (death, death_place) = + match find_field "DEAT" r.rsons with + [ Some r -> + if r.rsons = [] then + if r.rval = "Y" then (DeadDontKnowWhen, "") + else (DontKnowIfDead, "") + else + let d = + match find_field "DATE" r.rsons with + [ Some r -> + match date_of_field r.rval with + [ Some d -> Death Unspecified (Adef.cdate_of_date d) + | None -> DeadDontKnowWhen ] + | _ -> DeadDontKnowWhen ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (d, p) + | None -> + match birth with + [ Some d -> + let age = this_year - annee d in + if age >= 100 then (DontKnowIfDead, "") + else (NotDead, "") + | _ -> (NotDead, "") ] ] + in + let birth = Adef.codate_of_od birth in + let (burial, burial_place) = + let (buri, buri_place) = + match find_field "BURI" r.rsons with + [ Some r -> + if r.rsons = [] then + if r.rval = "Y" then (Buried Adef.codate_None, "") + else (UnknownBurial, "") + else + let d = + match find_field "DATE" r.rsons with + [ Some r -> date_of_field r.rval + | _ -> None ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (Buried (Adef.codate_of_od d), p) + | None -> (UnknownBurial, "") ] + in + let (crem, crem_place) = + match find_field "CREM" r.rsons with + [ Some r -> + if r.rsons = [] then + if r.rval = "Y" then (Cremated Adef.codate_None, "") + else (UnknownBurial, "") + else + let d = + match find_field "DATE" r.rsons with + [ Some r -> date_of_field r.rval + | _ -> None ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (Cremated (Adef.codate_of_od d), p) + | None -> (UnknownBurial, "") ] + in + match (buri, crem) with + [ (UnknownBurial, Cremated _) -> (crem, crem_place) + | _ -> (buri, buri_place) ] + in + let psources = + let l = add_sour gen r [] in + let l = + match find_field "BIRT" r.rsons with + [ Some r -> add_sour gen r l + | _ -> l ] + in + let l = + match find_field "DEAT" r.rsons with + [ Some r -> add_sour gen r l + | _ -> l ] + in + List.fold_left + (fun s s1 -> + if s = "" then s1 + else if s1 = "" then s + else s1 ^ "; " ^ s) + "" l + in + let empty = add_string gen "" in + let person = + {first_name = add_string gen first_name; + surname = add_string gen surname; + occ = occ; + public_name = add_string gen public_name; + photo = empty; + nick_names = if nick_name <> "" then [add_string gen nick_name] else []; + aliases = []; + first_names_aliases = + if first_name_alias <> "" then [add_string gen first_name_alias] + else []; + surnames_aliases = []; + titles = titles; occupation = add_string gen occupation; + sexe = sex; access = IfTitles; + birth = birth; birth_place = add_string gen birth_place; + baptism = bapt; baptism_place = add_string gen bapt_place; + death = death; death_place = add_string gen death_place; + burial = burial; burial_place = add_string gen burial_place; + family = Array.of_list family; + notes = notes; + psources = add_string gen psources; + cle_index = i} + and ascend = + {parents = parents; + consang = Adef.fix (-1)} + in + do gen.g_per.arr.(Adef.int_of_iper i) := Right person; + gen.g_asc.arr.(Adef.int_of_iper i) := Right ascend; + return () +; + +value add_fam gen r = + let i = fam_index gen r.rval in + let fath = + match find_field "HUSB" r.rsons with + [ Some r -> per_index gen r.rval + | None -> phony_per gen ] + in + let moth = + match find_field "WIFE" r.rsons with + [ Some r -> per_index gen r.rval + | None -> phony_per gen ] + in + do match gen.g_per.arr.(Adef.int_of_iper fath) with + [ Left _ -> () + | Right p -> + do if not (List.memq i (Array.to_list p.family)) then + p.family := Array.append p.family [| i |] + else (); + if p.sexe = Neutre then p.sexe := Masculin else (); + return () ]; + match gen.g_per.arr.(Adef.int_of_iper moth) with + [ Left _ -> () + | Right p -> + do if not (List.memq i (Array.to_list p.family)) then + p.family := Array.append p.family [| i |] + else (); + if p.sexe = Neutre then p.sexe := Feminin else (); + return () ]; + return + let children = + let rl = find_all_fields "CHIL" r.rsons in + List.map (fun r -> per_index gen r.rval) rl + in + let (marr, marr_place) = + match find_field "MARR" r.rsons with + [ Some r -> + let d = + match find_field "DATE" r.rsons with + [ Some r -> date_of_field r.rval + | _ -> None ] + in + let p = + match find_field "PLAC" r.rsons with + [ Some r -> r.rval + | _ -> "" ] + in + (d, p) + | None -> (None, "") ] + in + let div = + match find_field "DIV" r.rsons with + [ Some r -> + match find_field "DATE" r.rsons with + [ Some d -> Divorced (Adef.codate_of_od (date_of_field r.rval)) + | _ -> + match find_field "PLAC" r.rsons with + [ Some _ -> NotDivorced + | _ -> Divorced Adef.codate_None ] ] + | None -> NotDivorced ] + in + let empty = add_string gen "" in + let fsources = + let l = add_sour gen r [] in + let l = + match find_field "MARR" r.rsons with + [ Some r -> add_sour gen r l + | _ -> l ] + in + List.fold_left + (fun s s1 -> + if s = "" then s1 + else if s1 = "" then s + else s1 ^ "; " ^ s) + "" l + in + let fam = + {marriage = Adef.codate_of_od marr; + marriage_place = add_string gen marr_place; + divorce = div; + children = Array.of_list children; + comment = empty; origin_file = empty; fsources = add_string gen fsources; + fam_index = i} + and cpl = + {father = fath; + mother = moth} + in + do gen.g_fam.arr.(Adef.int_of_ifam i) := Right fam; + gen.g_cpl.arr.(Adef.int_of_ifam i) := Right cpl; + return () +; + +value add_note gen r = + Hashtbl.add gen.g_hnot r.rval r +; + +value add_source gen r = + () +; + +value treat_header r = + match ansel_option.val with + [ Some v -> ansel_characters.val := v + | None -> + match find_field "CHAR" r.rsons with + [ Some r -> + match r.rval with + [ "ANSEL" -> ansel_characters.val := True + | _ -> ansel_characters.val := False ] + | None -> () ] ] +; + +value make_gen gen r = + match r.rlab with + [ "HEAD" -> + do Printf.eprintf "*** Header ok\n"; + flush stderr; + treat_header r; + return () + | "INDI" -> add_indi gen r + | "FAM" -> add_fam gen r + | "NOTE" -> add_note gen r + | "SOUR" -> add_source gen r + | "TRLR" -> + do Printf.eprintf "*** Trailer ok\n"; + flush stderr; + return () + | s -> + do Printf.printf "Not implemented typ = %s\n" s; + flush stdout; + return () ] +; + +value rec sortable_by_date proj = + fun + [ [] -> True + | [e :: el] -> + match proj e with + [ Some d -> sortable_by_date proj el + | None -> False ] ] +; + +value sort_by_date proj list = + if sortable_by_date proj list then + Sort.list + (fun e1 e2 -> + match (proj e1, proj e2) with + [ (Some d1, Some d2) -> not (strictement_apres d1 d2) + | _ -> False ]) + list + else list +; + +(* Printing check errors *) + +value print_base_error base = + fun + [ AlreadyDefined p -> + Printf.printf "%s\nis defined several times\n" (denomination base p) + | OwnAncestor p -> + Printf.printf "%s\nis his/her own ancestor\n" (denomination base p) + | BadSexOfMarriedPerson p -> + Printf.printf "%s\n bad sex for a married person\n" + (denomination base p) ] +; + +value print_base_warning base = + fun + [ BirthAfterDeath p -> + Printf.printf "%s\n born after his/her death\n" (denomination base p) + | ChangedOrderOfChildren fam _ -> + let cpl = coi base fam.fam_index in + Printf.printf "Changed order of children of %s and %s\n" + (denomination base (poi base cpl.father)) + (denomination base (poi base cpl.mother)) + | ChildrenNotInOrder fam elder x -> + let cpl = coi base fam.fam_index in + do Printf.printf + "The following children of\n %s\nand\n %s\nare not in order:\n" + (denomination base (poi base cpl.father)) + (denomination base (poi base cpl.mother)); + Printf.printf "- %s\n" (denomination base elder); + Printf.printf "- %s\n" (denomination base x); + return () + | DeadTooEarlyToBeFather father child -> + do Printf.printf "%s\n" (denomination base child); + Printf.printf + " is born more than 2 years after the death of his/her father\n"; + Printf.printf "%s\n" (denomination base father); + return () + | MarriageDateAfterDeath p -> + do Printf.printf "%s\n" (denomination base p); + Printf.printf "married after his/her death\n"; + return () + | MarriageDateBeforeBirth p -> + do Printf.printf "%s\n" (denomination base p); + Printf.printf "married before his/her birth\n"; + return () + | MotherDeadAfterChildBirth mother child -> + Printf.printf "%s\n is born after the death of his/her mother\n%s\n" + (denomination base child) (denomination base mother) + | ParentBornAfterChild parent child -> + Printf.printf "%s born after his/her child %s\n" + (denomination base parent) (denomination base child) + | ParentTooYoung p a -> + Printf.printf "%s was parent at age of %d\n" (denomination base p) + (annee a) + | TitleDatesError p t -> + do Printf.printf "%s\n" (denomination base p); + Printf.printf "has incorrect title dates as:\n"; + Printf.printf " %s %s\n" (sou base t.t_title) + (sou base t.t_place); + return () + | YoungForMarriage p a -> + Printf.printf "%s married at age %d\n" (denomination base p) (annee a) ] +; + +value get_lev0 = + parser + [ [: `'0'; `' ' ? "space"; r1 = get_ident 0; r2 = get_ident 0; + r3 = get_to_eoln 0 ? "get to eoln"; + l = get_lev_list [] '1' ? "get lev list" :] -> + let (rlab, rval) = if r2 = "" then (r1, "") else (r2, r1) in + let rval = + if ansel_characters.val then Ansel.translate rval + else rval + in + let rcont = + if ansel_characters.val then Ansel.translate r3 + else r3 + in + {rlab = rlab; rval = rval; rcont = rcont; rsons = List.rev l} ] +; + +value make_arrays in_file = + let gen = + {g_per = {arr = [| |]; tlen = 0}; + g_asc = {arr = [| |]; tlen = 0}; + g_fam = {arr = [| |]; tlen = 0}; + g_cpl = {arr = [| |]; tlen = 0}; + g_str = {arr = [| |]; tlen = 0}; + g_hper = Hashtbl.create 3001; + g_hfam = Hashtbl.create 3001; + g_hstr = Hashtbl.create 3001; + g_hnot = Hashtbl.create 3001; + g_hnam = Hashtbl.create 3001; +(* + g_all = Hashtbl.create 3001; +*) + g_fnot = []} + in + let ic = + match in_file with + [ "" -> stdin + | f -> + let fname = + if Filename.check_suffix f ".ged" then f + else f ^ ".ged" + in + open_in f ] + in + let strm = Stream.of_channel ic in + do string_empty.val := add_string gen ""; + string_x.val := add_string gen "x"; + try + while True do + let r = get_lev0 strm in +(* + do Hashtbl.add gen.g_all r.rval (); return +*) + make_gen gen r; + done + with + [ Stream.Failure -> () ]; + if ic != stdin then close_in ic else (); + let nf n = + do Printf.printf "Note not found %s\n" n; + flush stdout; + return "" + in + List.iter + (fun (i, rl) -> + if titles_aurejac.val then + let (notes, titles) = treat_indi_notes_titles gen rl nf in + match gen.g_per.arr.(Adef.int_of_iper i) with + [ Left _ -> () + | Right p -> do p.notes := notes; p.titles := titles; return () ] + else + let notes = treat_indi_notes gen rl nf in + match gen.g_per.arr.(Adef.int_of_iper i) with + [ Left _ -> () + | Right p -> p.notes := notes ]) + gen.g_fnot; + for i = 0 to gen.g_per.tlen - 1 do + match gen.g_per.arr.(i) with + [ Right _ -> () + | Left lab -> + let (p, a) = unknown_per gen i in + do Printf.printf "Warning: undefined person %s\n" lab; + gen.g_per.arr.(i) := Right p; + gen.g_asc.arr.(i) := Right a; + return () ]; + done; + return + (gen.g_per, gen.g_asc, gen.g_fam, gen.g_cpl, gen.g_str) +; + +value make_subarrays (g_per, g_asc, g_fam, g_cpl, g_str) = + let persons = + let a = Array.create g_per.tlen (Obj.magic 0) in + do for i = 0 to g_per.tlen - 1 do + match g_per.arr.(i) with + [ Right p -> a.(i) := p + | Left lab -> failwith ("undefined person " ^ lab) ]; + done; + return a + in + let ascends = + let a = Array.create g_asc.tlen (Obj.magic 0) in + do for i = 0 to g_asc.tlen - 1 do + match g_asc.arr.(i) with + [ Right p -> a.(i) := p + | Left lab -> failwith ("undefined person " ^ lab) ]; + done; + return a + in + let families = + let a = Array.create g_fam.tlen (Obj.magic 0) in + do for i = 0 to g_fam.tlen - 1 do + match g_fam.arr.(i) with + [ Right f -> a.(i) := f + | Left lab -> failwith ("undefined family " ^ lab) ]; + done; + return a + in + let couples = + let a = Array.create g_cpl.tlen (Obj.magic 0) in + do for i = 0 to g_cpl.tlen - 1 do + match g_cpl.arr.(i) with + [ Right c -> a.(i) := c + | Left lab -> failwith ("undefined family " ^ lab) ]; + done; + return a + in + let strings = Array.sub g_str.arr 0 g_str.tlen in + (persons, ascends, families, couples, strings) +; + +value cache_of tab = + let c = {array = fun _ -> tab; get = fun []; len = Array.length tab} in + do c.get := fun i -> (c.array ()).(i); return c +; + +value make_base (persons, ascends, families, couples, strings) = + {persons = cache_of persons; + ascends = cache_of ascends; + families = cache_of families; + couples = cache_of couples; + strings = cache_of strings; + has_family_patches = False; + persons_of_name = fun []; + strings_of_fsname = fun []; + index_of_string = fun []; + persons_of_surname = {find = fun []; cursor = fun []; next = fun []}; + persons_of_first_name = {find = fun []; cursor = fun []; next = fun []}; + patch_person = fun []; patch_ascend = fun []; + patch_family = fun []; patch_couple = fun []; + patch_string = fun []; patch_name = fun []; commit_patches = fun []; + cleanup = fun () -> ()} +; + +value array_memq x a = + loop 0 where rec loop i = + if i == Array.length a then False + else if x == a.(i) then True + else loop (i + 1) +; + +value check_parents_children base = + let to_delete = ref [] in + do for i = 0 to base.persons.len - 1 do + let a = base.ascends.get i in + match a.parents with + [ Some ifam -> + let fam = foi base ifam in + let cpl = coi base ifam in + if array_memq (Adef.iper_of_int i) fam.children then () + else + let p = base.persons.get i in + do Printf.printf "%s is not the child of his/her parents\n" + (denomination base p); + Printf.printf "- %s\n" + (denomination base (poi base cpl.father)); + Printf.printf "- %s\n" + (denomination base (poi base cpl.mother)); + Printf.printf "=> no more parents for him/her\n"; + Printf.printf "\n"; + flush stdout; + a.parents := None; + return () + | None -> () ]; + done; + for i = 0 to base.families.len - 1 do + to_delete.val := []; + let fam = base.families.get i in + let cpl = base.couples.get i in + do for j = 0 to Array.length fam.children - 1 do + let a = aoi base fam.children.(j) in + let p = poi base fam.children.(j) in + match a.parents with + [ Some ifam -> + if Adef.int_of_ifam ifam <> i then + do Printf.printf "Other parents for %s\n" + (denomination base p); + Printf.printf "- %s\n" + (denomination base (poi base cpl.father)); + Printf.printf "- %s\n" + (denomination base (poi base cpl.mother)); + Printf.printf "=> deleted in this family\n"; + Printf.printf "\n"; + flush stdout; + to_delete.val := [p.cle_index :: to_delete.val]; + return () + else () + | None -> + do Printf.printf "%s has no parents but is the child of\n" + (denomination base p); + Printf.printf "- %s\n" + (denomination base (poi base cpl.father)); + Printf.printf "- %s\n" + (denomination base (poi base cpl.mother)); + Printf.printf "=> added parents\n"; + Printf.printf "\n"; + flush stdout; + a.parents := Some fam.fam_index; + return () ]; + done; + if to_delete.val <> [] then + let l = + List.fold_right + (fun ip l -> + if List.memq ip to_delete.val then l else [ip :: l]) + (Array.to_list fam.children) [] + in + fam.children := Array.of_list l + else (); + return (); + done; + return () +; + +value neg_year = + fun + [ Da (OrYear y2) y -> Da (OrYear (- abs y2)) (- abs y) + | Da p y -> Da p (- abs y) + | Dma m y -> Dma m (- abs y) + | Djma d m y -> Djma d m (- abs y) ] +; + +value neg_year_cdate cd = + Adef.cdate_of_date (neg_year (Adef.date_of_cdate cd)) +; + +value rec negative_date_ancestors base p = + do match Adef.od_of_codate p.birth with + [ Some d1 -> p.birth := Adef.codate_of_od (Some (neg_year d1)) + | _ -> () ]; + match p.death with + [ Death dr cd2 -> p.death := Death dr (neg_year_cdate cd2) + | _ -> () ]; + for i = 0 to Array.length p.family - 1 do + let fam = foi base p.family.(i) in + match Adef.od_of_codate fam.marriage with + [ Some d -> + fam.marriage := Adef.codate_of_od (Some (neg_year d)) + | None -> () ]; + done; + return + let a = aoi base p.cle_index in + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + do negative_date_ancestors base (poi base cpl.father); + negative_date_ancestors base (poi base cpl.mother); + return () + | _ -> () ] +; + +value negative_dates base = + for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d1, Death dr cd2) -> + let d2 = Adef.date_of_cdate cd2 in + if annee d1 > 0 && annee d2 > 0 && strictement_avant d2 d1 then + negative_date_ancestors base (base.persons.get i) + else () + | _ -> () ]; + done +; + +value finish_base base = + let persons = base.persons.array () in + let ascends = base.ascends.array () in + let families = base.families.array () in + let strings = base.strings.array () in + do for i = 0 to Array.length families - 1 do + let fam = families.(i) in + let children = + sort_by_date + (fun ip -> Adef.od_of_codate (persons.(Adef.int_of_iper ip).birth)) + (Array.to_list fam.children) + in + fam.children := Array.of_list children; + done; + for i = 0 to Array.length persons - 1 do + let p = persons.(i) in + let family = + sort_by_date + (fun ifam -> + Adef.od_of_codate + families.(Adef.int_of_ifam ifam).marriage) + (Array.to_list p.family) + in + p.family := Array.of_list family; + done; + for i = 0 to Array.length persons - 1 do + let p = persons.(i) in + let a = ascends.(i) in + if a.parents <> None && Array.length p.family != 0 + || p.notes <> string_empty.val then + do if sou base p.first_name = "?" then + do p.first_name := string_x.val; + p.occ := i; + return () + else (); + if sou base p.surname = "?" then + do p.surname := string_x.val; + p.occ := i; + return () + else (); + return () + else (); + done; + check_parents_children base; + if try_negative_dates.val then negative_dates base else (); + check_base base + (fun x -> do print_base_error base x; return Printf.printf "\n") + (fun x -> do print_base_warning base x; return Printf.printf "\n"); + flush stdout; + return () +; + +(* Main *) + +value in_file = ref ""; +value out_file = ref "a"; +value speclist = + [("-o", Arg.String (fun s -> out_file.val := s), " + Output data base (defaut: \"a\")."); + ("-lf", Arg.Set lowercase_first_names, " - Lowercase first names - + Force lowercase first names keeping only their initials as uppercase + characters."); + ("-ls", Arg.Set lowercase_surnames, " - Lowercase surnames - + Force lowercase surnames keeping only their initials as uppercase + characters. Try to keep lowercase particles."); + ("-efn", Arg.Set extract_first_names, " - Extract first names - [default] + When creating a person, if the GEDCOM first name part holds several + names, the first of this names becomes the person \"first name\" and + the complete GEDCOM first name part a \"first name alias\"."); + ("-no_efn", Arg.Clear extract_first_names, " + Cancels the previous option."); + ("-epn", Arg.Set extract_public_names, " - Extract public names - [default] + When creating a person, if the GEDCOM first name part looks like a + public name, i.e. holds: + * a number or a roman number, supposed to be a number of a + nobility title, + * one of the words: \"der\", \"die\", \"el\", \"le\", \"la\", \"the\", + supposed to be the beginning of a nick name, + then the GEDCOM first name part becomes the person \"public name\" + and its first word his \"first name\"."); + ("-no_epn", Arg.Clear extract_public_names, " + Cancels the previous option."); + ("-tnd", Arg.Set try_negative_dates, " - Try negative dates - + Set negative dates when inconsistency (e.g. birth after death)"); + ("-ansel", Arg.Unit (fun () -> ansel_option.val := Some True), + " - ANSEL encoding - + Force ANSEL encoding, overriding the possible setting in GEDCOM."); + ("-no_ansel", Arg.Unit (fun () -> ansel_option.val := Some False), + " - No ANSEL encoding - + No ANSEL encoding, overriding the possible setting in GEDCOM."); + ("-ta", Arg.Set titles_aurejac, " + [This option is ad hoc; please do not use it]")] +; + +value output_command_line bname = + let bdir = + if Filename.check_suffix bname ".gwb" then bname + else bname ^ ".gwb" + in + let oc = open_out (Filename.concat bdir "command.txt") in + do Printf.fprintf oc "%s" Sys.argv.(0); + for i = 1 to Array.length Sys.argv - 1 do + Printf.fprintf oc " %s" Sys.argv.(i); + done; + Printf.fprintf oc "\n"; + close_out oc; + return () +; + +value errmsg = "Usage: ged2gwb [] [options] where options are:"; + +value main () = + do Argl.parse speclist (fun s -> in_file.val := s) errmsg; return +(* + let r = Gc.get () in + do r.Gc.max_overhead := 10; Gc.set r; return +*) + let arrays = make_arrays in_file.val in + do Gc.compact (); return + let arrays = make_subarrays arrays in + let base = make_base arrays in + do finish_base base; + Iobase.output out_file.val base; + output_command_line out_file.val; + return () +; + +Printexc.catch main (); diff --git a/gwb2ged/Makefile b/gwb2ged/Makefile new file mode 100644 index 0000000000..f90c774e09 --- /dev/null +++ b/gwb2ged/Makefile @@ -0,0 +1,20 @@ +# $Id: Makefile,v 1.1 1998-09-01 14:32:13 ddr Exp $ + +include ../tools/Makefile.inc + +OCAMLI=-I ../src +OBJS=../src/argl.cmo ../src/adef.cmo ../src/name.cmo ../src/gutil.cmo ../src/iovalue.cmo ../src/btree.cmo ../src/iobase.cmo ../wserver/wserver.cmo ../src/util.cmo ../src/select.cmo gwb2ged.cmo + +all:: gwb2ged.out +opt:: gwb2ged.opt + +gwb2ged.out: $(OBJS) + ocamlc -custom unix.cma $(CAMLP4D)/gramlib.cma $(OBJS) $(LIBUNIX) -o gwb2ged.out + +gwb2ged.opt: $(OBJS:.cmo=.cmx) + ocamlopt unix.cmxa $(CAMLP4D)/gramlib.cmxa $(OBJS:.cmo=.cmx) $(LIBUNIX) -o gwb2ged.opt + +depend: + ocamldep $(OCAMLI) *.ml* > .depend + +include .depend diff --git a/gwb2ged/gwb2ged.ml b/gwb2ged/gwb2ged.ml new file mode 100644 index 0000000000..5ff5b790fb --- /dev/null +++ b/gwb2ged/gwb2ged.ml @@ -0,0 +1,497 @@ +(* $Id: gwb2ged.ml,v 1.1 1998-09-01 14:32:13 ddr Exp $ *) + +open Def; +open Gutil; + +value ged_month = + fun + [ 1 -> "JAN" + | 2 -> "FEB" + | 3 -> "MAR" + | 4 -> "APR" + | 5 -> "MAY" + | 6 -> "JUN" + | 7 -> "JUL" + | 8 -> "AUG" + | 9 -> "SEP" + | 10 -> "OCT" + | 11 -> "NOV" + | 12 -> "DEC" + | _ -> failwith "ged_month" ] +; + +value ged_header base oc ifile ofile = + do Printf.fprintf oc "0 HEAD\n"; + Printf.fprintf oc "1 SOUR GeneWeb\n"; + Printf.fprintf oc "2 VERS %s\n" Util.version; + Printf.fprintf oc "2 NAME %s\n" (Filename.basename Sys.argv.(0)); + Printf.fprintf oc "2 CORP INRIA\n"; + Printf.fprintf oc "3 ADDR Domaine de Voluceau\n"; + Printf.fprintf oc "4 CONT B.P 105 - Rocquencourt\n"; + Printf.fprintf oc "4 CITY Le Chesnay Cedex\n"; + Printf.fprintf oc "4 POST 78153\n"; + Printf.fprintf oc "4 CTRY France\n"; + Printf.fprintf oc "3 PHON +33 01 39 63 55 11\n"; + Printf.fprintf oc "2 DATA %s\n" + (let fname = Filename.basename ifile in + if Filename.check_suffix fname ".gwb" then fname else fname ^ ".gwb"); + try + let tm = Unix.localtime (Unix.time ()) in + let mon = ged_month (tm.Unix.tm_mon + 1) in + do Printf.fprintf oc "1 DATE %02d %s %d\n" tm.Unix.tm_mday mon + (1900 + tm.Unix.tm_year); + Printf.fprintf oc "2 TIME %02d:%02d:%02d\n" tm.Unix.tm_hour + tm.Unix.tm_min tm.Unix.tm_sec; + return () + with _ -> (); + if ofile <> "" then + Printf.fprintf oc "1 FILE %s\n" (Filename.basename ofile) + else (); + Printf.fprintf oc "1 GEDC\n"; + Printf.fprintf oc "2 VERS 5.5\n"; + Printf.fprintf oc "2 FORM LINEAGE-LINKED\n"; + Printf.fprintf oc "1 CHAR ASCII\n"; + return () +; + +value ged_1st_name base p = + match sou base p.public_name with + [ "" -> sou base p.first_name + | n -> n ] +; + +value ged_name base oc per = + do Printf.fprintf oc "1 NAME %s/%s/\n" (ged_1st_name base per) + (sou base per.surname); + match per.nick_names with + [ [nn :: _] -> Printf.fprintf oc "2 NICK %s\n" (sou base nn) + | [] -> () ]; + return () +; + +value ged_sex base oc per = + match per.sexe with + [ Masculin -> Printf.fprintf oc "1 SEX M\n" + | Feminin -> Printf.fprintf oc "1 SEX F\n" + | Neutre -> () ] +; + +value ged_date oc = + fun + [ Djma d m y -> Printf.fprintf oc "%02d %s %d" d (ged_month m) y + | Dma m y -> Printf.fprintf oc "%s %d" (ged_month m) y + | Da p y -> + do match p with + [ Sure -> () + | About -> Printf.fprintf oc "ABT " + | Maybe -> Printf.fprintf oc "EST " + | Before -> Printf.fprintf oc "BEF " + | After -> Printf.fprintf oc "AFT " + | OrYear i -> Printf.fprintf oc "BET " ]; + Printf.fprintf oc "%d" y; + match p with + [ OrYear i -> Printf.fprintf oc " AND %d" i + | _ -> () ]; + return () ] +; + +value ged_ev_detail oc n d pl = + do match (d, pl) with + [ (None, "") -> Printf.fprintf oc " Y" + | _ -> () ]; + Printf.fprintf oc "\n"; + match d with + [ Some d -> + do Printf.fprintf oc "%d DATE " n; + ged_date oc d; + Printf.fprintf oc "\n"; + return () + | None -> () ]; + if pl <> "" then Printf.fprintf oc "%d PLAC %s\n" n pl + else (); + return () +; + +value ged_ind_ev_str base oc per = + do match (Adef.od_of_codate per.birth, sou base per.birth_place) with + [ (None, "") -> () + | (None, pl) -> + do Printf.fprintf oc "1 BIRT"; + ged_ev_detail oc 2 None pl; + return () + | (od, pl) -> + do Printf.fprintf oc "1 BIRT"; + ged_ev_detail oc 2 od pl; + return () ]; + let pl = sou base per.death_place in + match (Adef.od_of_codate per.baptism, sou base per.baptism_place) with + [ (None, "") -> () + | (od, pl) -> + do Printf.fprintf oc "1 BAPM"; + ged_ev_detail oc 2 od pl; + return () ]; + let pl = sou base per.death_place in + match per.death with + [ NotDead -> () + | Death dr cd -> + do Printf.fprintf oc "1 DEAT"; + ged_ev_detail oc 2 (Some (Adef.date_of_cdate cd)) pl; + return () + | DeadYoung | DeadDontKnowWhen -> + do Printf.fprintf oc "1 DEAT"; + ged_ev_detail oc 2 None pl; + return () + | DontKnowIfDead -> Printf.fprintf oc "1 DEAT\n" ]; + let pl = sou base per.burial_place in + match per.burial with + [ UnknownBurial -> () + | Buried cod -> + do Printf.fprintf oc "1 BURI"; + ged_ev_detail oc 2 (Adef.od_of_codate cod) pl; + return () + | Cremated cod -> + do Printf.fprintf oc "1 CREM"; + ged_ev_detail oc 2 (Adef.od_of_codate cod) pl; + return () ]; + return () +; + +value ged_title base oc per tit = + do Printf.fprintf oc "1 TITL "; + Printf.fprintf oc "%s" (sou base tit.t_title); + match sou base tit.t_place with + [ "" -> () + | pl -> Printf.fprintf oc ", %s" pl ]; + if tit.t_nth <> 0 then Printf.fprintf oc ", %d" tit.t_nth else (); + Printf.fprintf oc "\n"; + match + (Adef.od_of_codate tit.t_date_start, + Adef.od_of_codate tit.t_date_end) + with + [ (None, None) -> () + | (Some sd, None) -> + do Printf.fprintf oc "2 DATE "; + ged_date oc sd; + Printf.fprintf oc "\n"; + return () + | (None, Some sd) -> + do Printf.fprintf oc "2 DATE BEF "; + ged_date oc sd; + Printf.fprintf oc "\n"; + return () + | (Some sd1, Some sd2) -> + do Printf.fprintf oc "2 DATE BET "; + ged_date oc sd1; + Printf.fprintf oc " AND "; + ged_date oc sd2; + Printf.fprintf oc "\n"; + return () ]; + match tit.t_name with + [ Tmain -> Printf.fprintf oc "2 NOTE %s\n" (sou base per.public_name) + | Tname n -> Printf.fprintf oc "2 NOTE %s\n" (sou base n) + | Tnone -> () ]; + return () +; + +value ged_ind_attr_str base oc per = + do match sou base per.occupation with + [ "" -> () + | occu -> Printf.fprintf oc "1 OCCU %s\n" occu ]; + List.iter (ged_title base oc per) per.titles; + return () +; + +value ged_famc base (per_sel, fam_sel) oc asc = + match asc.parents with + [ Some ifam -> + if fam_sel ifam then + Printf.fprintf oc "1 FAMC @F%d@\n" (Adef.int_of_ifam ifam) + else () + | None -> () ] +; + +value ged_fams base (per_sel, fam_sel) oc ifam = + if fam_sel ifam then + Printf.fprintf oc "1 FAMS @F%d@\n" (Adef.int_of_ifam ifam) + else () +; + +value ged_psource base oc per = + match sou base per.psources with + [ "" -> () + | s -> Printf.fprintf oc "1 SOUR %s\n" s ] +; + +value br = "
"; + +value rec display_note oc s i = + if i == String.length s then Printf.fprintf oc "\n" + else + if i <= String.length s - String.length br + && String.sub s i (String.length br) = br then + do Printf.fprintf oc "\n2 CONT "; return + let i = i + String.length br in + let i = + if i < String.length s && s.[i] == '\n' then i + 1 + else i + in + display_note oc s i + else if s.[i] == '\n' then + do Printf.fprintf oc "\n2 CONC "; return + display_note oc s (i + 1) + else + do output_char oc s.[i]; return + display_note oc s (i + 1) +; + +value ged_note base oc per = + match sou base per.notes with + [ "" -> () + | s -> + do Printf.fprintf oc "1 NOTE "; + display_note oc s 0; + return () ] +; + +value ged_marriage base oc fam = + match + (Adef.od_of_codate fam.marriage, sou base fam.marriage_place) + with + [ (None, "") -> () + | (d, pl) -> + do Printf.fprintf oc "1 MARR"; + ged_ev_detail oc 2 d pl; + return () ] +; + +value ged_divorce base oc fam = + match fam.divorce with + [ NotDivorced -> () + | Divorced cd -> + let d = Adef.od_of_codate cd in + do Printf.fprintf oc "1 DIV"; + ged_ev_detail oc 2 d ""; + return () ] +; + +value ged_child base (per_sel, fam_sel) oc chil = + if per_sel chil then + Printf.fprintf oc "1 CHIL @I%d@\n" (Adef.int_of_iper chil) + else () +; + +value ged_fsource base oc fam = + match sou base fam.fsources with + [ "" -> () + | s -> Printf.fprintf oc "1 SOUR %s\n" s ] +; + +value ged_comment base oc fam = + match sou base fam.comment with + [ "" -> () + | s -> Printf.fprintf oc "1 NOTE %s\n" s ] +; + +value has_personal_infos base per asc = + if asc.parents <> None then True + else if sou base per.first_name <> "?" then True + else if sou base per.surname <> "?" then True + else if per.birth <> Adef.codate_None then True + else if sou base per.birth_place <> "" then True + else if per.death <> NotDead && per.death <> DontKnowIfDead then True + else if sou base per.occupation <> "" then True + else if per.titles <> [] then True + else False +; + +value ged_ind_record base sel oc i = + let per = base.persons.get i in + let asc = base.ascends.get i in + if has_personal_infos base per asc then + do Printf.fprintf oc "0 @I%d@ INDI\n" i; + ged_name base oc per; + ged_sex base oc per; + ged_ind_ev_str base oc per; + ged_ind_attr_str base oc per; + ged_famc base sel oc asc; + Array.iter (ged_fams base sel oc) per.family; + ged_psource base oc per; + ged_note base oc per; + return () + else () +; + +value ged_fam_record base ((per_sel, fam_sel) as sel) oc i = + let fam = base.families.get i in + if is_deleted_family fam then () + else + let cpl = base.couples.get i in + do Printf.fprintf oc "0 @F%d@ FAM\n" i; + ged_marriage base oc fam; + ged_divorce base oc fam; + if has_personal_infos base (poi base cpl.father) (aoi base cpl.father) + && per_sel cpl.father + then + Printf.fprintf oc "1 HUSB @I%d@\n" (Adef.int_of_iper cpl.father) + else (); + if has_personal_infos base (poi base cpl.mother) (aoi base cpl.mother) + && per_sel cpl.mother + then + Printf.fprintf oc "1 WIFE @I%d@\n" (Adef.int_of_iper cpl.mother) + else (); + Array.iter (ged_child base sel oc) fam.children; + ged_fsource base oc fam; + ged_comment base oc fam; + return () +; + +value find_person base p1 po p2 = + try Gutil.person_ht_find_unique base p1 p2 po with + [ Not_found -> + do Printf.eprintf "Not found: %s%s %s\n" + p1 (if po == 0 then "" else " " ^ string_of_int po) p2; + flush stderr; + return exit 2 ] +; + +value gwb2ged base ifile ofile anc desc mem = + let anc = + match anc with + [ Some (p1, po, p2) -> Some (find_person base p1 po p2) + | None -> None ] + in + let desc = + match desc with + [ Some (p1, po, p2) -> Some (find_person base p1 po p2) + | None -> None ] + in + do if not mem then + let _ = base.persons.array () in + let _ = base.ascends.array () in + let _ = base.couples.array () in + let _ = base.families.array () in + () + else (); + return + let oc = if ofile = "" then stdout else open_out ofile in + let ((per_sel, fam_sel) as sel) = Select.functions base anc desc in + do ged_header base oc ifile ofile; + flush oc; + for i = 0 to base.persons.len - 1 do + if per_sel (Adef.iper_of_int i) then ged_ind_record base sel oc i + else (); + done; + flush oc; + for i = 0 to base.families.len - 1 do + if fam_sel (Adef.ifam_of_int i) then ged_fam_record base sel oc i + else (); + done; + flush oc; + Printf.fprintf oc "0 TRLR\n"; + flush oc; + if ofile = "" then () else close_out oc; + return () +; + +value ifile = ref ""; +value ofile = ref "a.ged"; +value mem = ref False; +value anc_1st = ref ""; +value anc_occ = ref 0; +value anc_2nd = ref ""; +value desc_1st = ref ""; +value desc_occ = ref 0; +value desc_2nd = ref ""; + +type arg_state = + [ ASnone | ASwaitAncOcc | ASwaitAncSurn | ASwaitDescOcc | ASwaitDescSurn ] +; +value arg_state = ref ASnone; + +value usage = "Usage: " ^ Sys.argv.(0) ^ " [options] +If both options -a and -d are used, intersection is assumed. +Options are:"; + +value speclist = + [("-o", + Arg.String (fun x -> do ofile.val := x; return arg_state.val := ASnone), + ": output file name (default: a.ged)"); + ("-a", + Arg.String + (fun s -> do anc_1st.val := s; return arg_state.val := ASwaitAncOcc), + "\"<1st_name>\" [num] \"\": select ancestors of"); + ("-d", + Arg.String + (fun s -> do desc_1st.val := s; return arg_state.val := ASwaitDescOcc), + "\"<1st_name>\" [num] \"\": select descendants of"); + ("-mem", + Arg.Unit (fun () -> do mem.val := True; return arg_state.val := ASnone), + ": save memory space, but slower")] +; + +value anon_fun s = + match arg_state.val with + [ ASnone -> ifile.val := s + | ASwaitAncOcc -> + try + do anc_occ.val := int_of_string s; return + arg_state.val := ASwaitAncSurn + with + [ Failure _ -> + do anc_occ.val := 0; anc_2nd.val := s; return + arg_state.val := ASnone ] + | ASwaitAncSurn -> + do anc_2nd.val := s; return arg_state.val := ASnone + | ASwaitDescOcc -> + try + do desc_occ.val := int_of_string s; return + arg_state.val := ASwaitDescSurn + with + [ Failure _ -> + do desc_occ.val := 0; desc_2nd.val := s; return + arg_state.val := ASnone ] + | ASwaitDescSurn -> + do desc_2nd.val := s; return arg_state.val := ASnone ] +; + +value main () = + do Argl.parse speclist anon_fun usage; return + let anc = + if anc_1st.val <> "" then + if anc_2nd.val = "" then + do Printf.eprintf "Misused option -a\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 + else Some (anc_1st.val, anc_occ.val, anc_2nd.val) + else None + in + let desc = + if desc_1st.val <> "" then + if desc_2nd.val = "" then + do Printf.eprintf "Misused option -d\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 + else Some (desc_1st.val, desc_occ.val, desc_2nd.val) + else None + in + do if ofile.val = "-" then ofile.val := "" else (); + if ifile.val = "" then + do Printf.eprintf "Missing base name\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 + else (); + match + try Some (Iobase.input ifile.val) with [ Sys_error _ -> None ] + with + [ Some base -> gwb2ged base ifile.val ofile.val anc desc mem.val + | None -> + do Printf.eprintf "Can't open base %s\n" ifile.val; + flush stderr; + return exit 0 ]; + return () +; + +Printexc.catch main (); diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000000..d11e4df6dc --- /dev/null +++ b/src/Makefile @@ -0,0 +1,71 @@ +# $Id: Makefile,v 1.1 1998-09-01 14:32:02 ddr Exp $ + +include ../tools/Makefile.inc + +OCAMLI=-I ../wserver +GWC_OBJS=argl.cmo mhashtbl.cmo lock.cmo adef.cmo iovalue.cmo name.cmo gutil.cmo btree.cmo iobase.cmo check.cmo pqueue.cmo consang.cmo gwcomp.cmo gwc.cmo +CONSANG_OBJS=argl.cmo mhashtbl.cmo lock.cmo adef.cmo iovalue.cmo name.cmo gutil.cmo btree.cmo iobase.cmo pqueue.cmo consang.cmo mk_consang.cmo +GWD_OBJS=../wserver/wserver.cmo argl.cmo mhashtbl.cmo lock.cmo adef.cmo iovalue.cmo name.cmo gutil.cmo btree.cmo iobase.cmo pqueue.cmo consang.cmo num.cmo util.cmo date.cmo srcfile.cmo perso.cmo update.cmo updateInd.cmo updateIndOk.cmo updateFam.cmo updateFamOk.cmo merge.cmo mergeFam.cmo mergeFamOk.cmo mergeInd.cmo mergeIndOk.cmo relation.cmo relationLink.cmo ascend.cmo descend.cmo alln.cmo some.cmo advSearchOk.cmo birthday.cmo birth.cmo title.cmo family.cmo base64.cmo gwd.cmo +GWU_OBJS=argl.cmo adef.cmo iovalue.cmo name.cmo gutil.cmo btree.cmo iobase.cmo select.cmo gwu.cmo +all:: out +PHONYGWD_OBJS=../wserver/wserver.cmo argl.cmo phonygwd.cmo + +out:: def.syn.cmo gwc.out consang.out gwd.out gwu.out phonygwd.out i18n_check.out + $(RM) lgwd + cp gwd.out lgwd + +opt:: def.syn.cmo gwc.opt consang.opt gwd.opt gwu.opt + $(RM) lgwd + cp gwd.opt lgwd + +clean:: + $(RM) lgwd + +gwc.out: $(GWC_OBJS) + $(OCAMLC) -custom unix.cma $(GWC_OBJS) $(LIBUNIX) -o gwc.out + +gwc.opt: $(GWC_OBJS:.cmo=.cmx) + $(OCAMLOPT) unix.cmxa $(GWC_OBJS:.cmo=.cmx) $(LIBUNIX) -o gwc.opt + +consang.out: $(CONSANG_OBJS) + $(OCAMLC) -custom unix.cma $(LIBUNIX) $(CONSANG_OBJS) -o consang.out + +consang.opt: $(CONSANG_OBJS:.cmo=.cmx) + $(OCAMLOPT) unix.cmxa $(LIBUNIX) $(CONSANG_OBJS:.cmo=.cmx) -o consang.opt + +gwd.out: $(GWD_OBJS) + $(OCAMLC) -custom unix.cma $(CAMLP4D)/gramlib.cma $(GWD_OBJS) $(LIBUNIX) -o gwd.out + +gwd.opt: $(GWD_OBJS:.cmo=.cmx) + $(OCAMLOPT) unix.cmxa $(CAMLP4D)/gramlib.cmxa $(GWD_OBJS:.cmo=.cmx) $(LIBUNIX) -o gwd.opt + +gwu.out: $(GWU_OBJS) + $(OCAMLC) -custom unix.cma $(LIBUNIX) $(GWU_OBJS) -o gwu.out + +gwu.opt: $(GWU_OBJS:.cmo=.cmx) + $(OCAMLOPT) unix.cmxa $(LIBUNIX) $(GWU_OBJS:.cmo=.cmx) -o gwu.opt + +phonygwd.out: $(PHONYGWD_OBJS) + $(OCAMLC) -custom unix.cma $(LIBUNIX) $(PHONYGWD_OBJS) -o phonygwd.out + +i18n_check.out: i18n_check.cmo + $(OCAMLC) i18n_check.cmo -o i18n_check.out + +i18n: pr_transl.cmo always + if test -f i18n; then mv i18n i18n.bak; fi + OBJS=`(grep -w -c "transl conf" *.ml;grep -w -c "transl_nth conf" *.ml) | grep -v :0 | sed s/:.*$$//`; for i in $$OBJS; do echo $$i 1>&2; camlp4r pa_ifdef.cmo ./pa_lock.cmo ./pa_html.cmo ./pr_transl.cmo pa_extend.cmo $$i; done | sort | uniq > i18n + +always: + +iovalue.cmo: q_codes.cmo +iovalue.cmx: q_codes.cmo +gwc.cmo mk_consang.cmo: pa_lock.cmo +gwc.cmx mk_consang.cmx: pa_lock.cmo + +ascend.cmo birthday.cmo descend.cmo merge.cmo mergeInd.cmo mergeIndOk.cmo mergeFam.cmo mergeFamOk.cmo relationLink.cmo update.cmo updateInd.cmo updateIndOk.cmo updateFam.cmo: pa_html.cmo +ascend.cmx birthday.cmx descend.cmx merge.cmx mergeInd.cmx mergeIndOk.cmx mergeFam.cmx mergeFamOk.cmo relationLink.cmx update.cmx updateInd.cmx updateIndOk.cmo updateFam.cmx: pa_html.cmo + +depend: + ocamldep $(OCAMLI) *.ml* > .depend + +include .depend diff --git a/src/adef.ml b/src/adef.ml new file mode 100644 index 0000000000..0b504d3dc0 --- /dev/null +++ b/src/adef.ml @@ -0,0 +1,74 @@ +(* $Id: adef.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +type iper = int; +type ifam = int; +type istr = int; +type fix = int; +type cdate = int; +type codate = int; + +value float_of_fix x = float x /. 1000000.0; +value fix_of_float x = truncate (x *. 1000000.0 +. 0.5); +external fix : int -> fix = "%identity"; +external fix_repr : fix -> int = "%identity"; + +external int_of_iper : iper -> int = "%identity"; +external iper_of_int : int -> iper = "%identity"; +external int_of_ifam : ifam -> int = "%identity"; +external ifam_of_int : int -> ifam = "%identity"; +external int_of_istr : istr -> int = "%identity"; +external istr_of_int : int -> istr = "%identity"; + +type precision = [ Sure | About | Maybe | Before | After | OrYear of int ]; +type date = + [ Djma of int and int and int + | Dma of int and int + | Da of precision and int ] +; + +value cyoy y = if y <= 0 then 2500 - y else y; + +value cdate_of_date = + fun + [ Djma d m y -> ((cyoy y * 12 + m - 1) * 31 + d - 1) * 8 + | Dma m y -> (cyoy y * 12 + m - 1) * 8 + 1 + | Da Sure y -> cyoy y * 8 + 2 + | Da About y -> cyoy y * 8 + 3 + | Da Maybe y -> cyoy y * 8 + 4 + | Da Before y -> cyoy y * 8 + 5 + | Da After y -> cyoy y * 8 + 6 + | Da (OrYear y2) y -> ((cyoy y2 * 5000) + cyoy y) * 8 + 7 ] +; + +value yocy y = if y >= 2500 then 2500 - y else y; + +value date_of_cdate c = + match (c mod 8, c / 8) with + [ (0, c) -> + let d = c mod 31 + 1 in + let c = c / 31 in + let m = c mod 12 + 1 in + Djma d m (yocy (c / 12)) + | (1, c) -> + let m = c mod 12 + 1 in + Dma m (yocy (c / 12)) + | (2, c) -> Da Sure (yocy c) + | (3, c) -> Da About (yocy c) + | (4, c) -> Da Maybe (yocy c) + | (5, c) -> Da Before (yocy c) + | (6, c) -> Da After (yocy c) + | (_, c) -> Da (OrYear (yocy (c / 5000))) (yocy (c mod 5000)) ] +; + +value codate_of_od = + fun + [ None -> 0 + | Some d -> cdate_of_date d * 2 ] +; + +value od_of_codate c = + if c == 0 then None + else Some (date_of_cdate (c / 2)) +; + +value codate_None = codate_of_od None; diff --git a/src/adef.mli b/src/adef.mli new file mode 100644 index 0000000000..f036ab7ec1 --- /dev/null +++ b/src/adef.mli @@ -0,0 +1,34 @@ +(* $Id: adef.mli,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +type iper = 'a; +type ifam = 'a; +type istr = 'a; +type fix = 'a; +type cdate = 'a; +type codate = 'a; + +type precision = [ Sure | About | Maybe | Before | After | OrYear of int ]; +type date = + [ Djma of int and int and int + | Dma of int and int + | Da of precision and int ] +; + +value float_of_fix : fix -> float; +value fix_of_float : float -> fix; +external fix : int -> fix = "%identity"; +external fix_repr : fix -> int = "%identity"; + +value date_of_cdate : cdate -> date; +value cdate_of_date : date -> cdate; + +value codate_None : codate; +value od_of_codate : codate -> option date; +value codate_of_od : option date -> codate; + +external int_of_iper : iper -> int = "%identity"; +external iper_of_int : int -> iper = "%identity"; +external int_of_ifam : ifam -> int = "%identity"; +external ifam_of_int : int -> ifam = "%identity"; +external int_of_istr : istr -> int = "%identity"; +external istr_of_int : int -> istr = "%identity"; diff --git a/src/advSearchOk.ml b/src/advSearchOk.ml new file mode 100644 index 0000000000..2a9b08b0f5 --- /dev/null +++ b/src/advSearchOk.ml @@ -0,0 +1,224 @@ +(* camlp4r ./pa_html.cmo ./def.syn.cmo *) +(* $Id: advSearchOk.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +value get_number var key env = p_getint env (var ^ "_" ^ key); + +value reconstitute_date 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 (Djma d m y) + else None + | None -> + if m >= 1 && m <= 12 then Some (Dma m y) + else None ] + | None -> + let prec = Sure in + Some (Da prec y) ] + | 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 + loop1 0 j_ini where 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)) +; + +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; return 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 age_autorise conf base 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; return v ] + in + match (d1, d2) with + [ (Some d1, Some d2) -> + match df () with + [ Some d when age_autorise conf base p -> + if d strictement_avant d1 then False + else if d strictement_apres d2 then False + else True + | _ -> False ] + | (Some d1, _) -> + match df () with + [ Some d when age_autorise conf base p -> + if d strictement_avant d1 then False else True + | _ -> False ] + | (_, Some d2) -> + match df () with + [ Some d when age_autorise conf base p -> + if d strictement_apres d2 then False else True + | _ -> False ] + | _ -> True ] + in + let list = ref [] in + let len = ref 0 in + let test_person p = + if test "first_name" (fun x -> name_eq x (sou base p.first_name)) + && test "surname" (fun x -> name_eq x (sou base p.surname)) + && test "sex" + (fun + [ "M" -> p.sexe = Masculin + | "F" -> p.sexe = Feminin + | _ -> True ]) + && test "married" + (fun + [ "Y" -> p.family <> [| |] + | "N" -> p.family = [| |] + | _ -> True ]) + && test_auth p "birth_place" + (fun x -> name_incl x (sou base p.birth_place)) + && test_date p "birth" (fun () -> Adef.od_of_codate p.birth) + && test_auth p "baptism_place" + (fun x -> name_incl x (sou base p.baptism_place)) + && test_date p "baptism" (fun () -> Adef.od_of_codate p.baptism) + && test_auth p "death" + (fun d -> + match (d, p.death) with + [ ("Dead", NotDead | DontKnowIfDead) -> False + | ("Dead", _) -> True + | ("NotDead", NotDead) -> True + | ("NotDead", _) -> False + | _ -> True ]) + && test_auth p "death_place" + (fun x -> name_incl x (sou base p.death_place)) + && test_date p "death" + (fun () -> + match p.death with + [ Death _ cd -> Some (Adef.date_of_cdate cd) + | _ -> None ]) + && test_auth p "burial_place" + (fun x -> name_incl x (sou base p.burial_place)) + && test_date p "burial" + (fun () -> + match p.burial with + [ Buried cod -> Adef.od_of_codate cod + | Cremated cod -> Adef.od_of_codate cod + | _ -> None ]) + && test_auth p "occu" (fun x -> name_incl x (sou base p.occupation)) + then + do list.val := [p :: list.val]; + incr len; + return () + else () + in + do if gets "first_name" <> "" || gets "surname" <> "" then + let (slist, _) = + if gets "first_name" <> "" then + Some.persons_of_fsname base base.persons_of_first_name.find + (fun x -> x.first_name) (gets "first_name") + else + Some.persons_of_fsname base base.persons_of_surname.find + (fun x -> x.surname) (gets "surname") + in + let slist = List.fold_right (fun (_, _, l) sl -> l @ sl) slist [] in + List.iter (fun ip -> test_person (poi base ip)) slist + else + for i = 0 to base.persons.len - 1 do + if len.val > max_answers then () + else test_person (base.persons.get i); + done; + return (List.rev list.val, len.val) +; + +value print_result conf base max_answers (list, len) = + if len > max_answers then + do Wserver.wprint (fcapitale (ftransl conf "more than %d answers")) + max_answers; + Wserver.wprint "\n

\n"; + return () + else if len == 0 then + Wserver.wprint "%s\n" (capitale (transl conf "no match")) + else + tag "ul" begin + List.iter + (fun p -> + do Wserver.wprint "

  • \n"; + afficher_personne_referencee conf base p; + Date.afficher_dates_courtes conf base p; + return ()) + list; + if len > max_answers then Wserver.wprint "
  • \n...\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; + return () +; diff --git a/src/alln.ml b/src/alln.ml new file mode 100644 index 0000000000..68bb34c3c7 --- /dev/null +++ b/src/alln.ml @@ -0,0 +1,231 @@ +(* $Id: alln.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Config; +open Util; +open Gutil; + +value print_menu mode conf senv base is_fam liste len par_frequence = + let titre _ = + do if is_fam then + Wserver.wprint (fcapitale (ftransl conf "the %d surnames")) len + else + Wserver.wprint (fcapitale (ftransl conf "the %d first names")) len; + Wserver.wprint " (%d %s)" base.persons.len + (transl_nth conf "person/persons" 1); + return () + in + do header conf titre; + let _ = + List.fold_left + (fun last (x, c, _) -> + let i = x.[initiale x] in + let same_than_last = + match last with + [ Some (i1, c1) -> if par_frequence then c = c1 else i = i1 + | _ -> False ] + in + do if not same_than_last then + let t = + if par_frequence then string_of_int c else String.make 1 i + in + Wserver.wprint "%s\n" + (commd conf) mode senv (if par_frequence then "F" else "A") + t t + else (); + return Some (i, c)) + None liste + in + (); + if p_getenv conf.env "k" <> Some "" then + Wserver.wprint "

    \n%s\n" + (commd conf) mode senv (if par_frequence then "F" else "A") + (capitale (transl conf "the whole list")) + else (); + trailer conf; + return () +; + +value print_all mode conf senv base is_fam liste len par_frequence = + let title _ = + do if is_fam then + Wserver.wprint (fcapitale (ftransl conf "the %d surnames")) len + else + Wserver.wprint (fcapitale (ftransl conf "the %d first names")) len; + Wserver.wprint " (%d %s)" base.persons.len + (transl_nth conf "person/persons" 1); + return () + in + do header conf title; + print_alphab_list + (fun (x, c, _) -> + if par_frequence then string_of_int c + else String.sub x (initiale x) 1) + (fun (x, c, istr) -> + do Wserver.wprint "" (commd conf) mode + senv (code_varenv (sou base istr)); + Wserver.wprint "%s%s\n" + (if is_fam then surname_end x ^ surname_begin x else x) + (if par_frequence then "" else " (" ^ string_of_int c ^ ")"); + return ()) + liste; + trailer conf; + return () +; + +value print_elem mode conf base senv is_fam par_frequence (x, c, istr) = + do Wserver.wprint ""; + if is_fam then Wserver.wprint "%s%s" (surname_end x) (surname_begin x) + else Wserver.wprint "%s" x; + Wserver.wprint ""; + if not par_frequence then Wserver.wprint " (%d)" c else (); + Wserver.wprint "\n"; + return () +; + +value print_frequence mode conf senv base is_fam liste len f = + let liste = + List.fold_right + (fun (x, c, ip) liste -> + if c == f then [(x, c, ip) :: liste] else liste) + liste [] + in + let len = List.length liste in + let title _ = + let lab = + if is_fam then transl_nth conf "surname/surnames" 1 + else transl_nth conf "first name/first names" 1 + in + Wserver.wprint "%s %s %d %s" + (capitale lab) (transl conf "shared by") f + (transl_nth conf "person/persons" (if f == 1 then 0 else 1)) + in + do header conf title; + print_alphab_list (fun (x, _, _) -> String.sub x (initiale x) 1) + (print_elem mode conf base senv is_fam True) liste; + trailer conf; + return () +; + +value rec same_initial s1 i1 s2 i2 = + if i1 >= String.length s1 || i2 >= String.length s2 then True + else if s1.[i1] == s2.[i2] then same_initial s1 (succ i1) s2 (succ i2) + else False +; + +value print_alphab mode conf senv base is_fam liste len l = + let liste = + List.fold_right + (fun (x, c, ip) liste -> + if same_initial l 0 x (initiale x) then [(x, c, ip) :: liste] + else liste) + liste [] + in + let len = List.length liste in + let title _ = + let lab = + if is_fam then transl_nth conf "surname/surnames" 1 + else transl_nth conf "first name/first names" 1 + in + Wserver.wprint "%s %s %s" (capitale lab) (transl conf "starting with") l + in + let crit_len = String.length l + 1 in + do header conf title; + print_alphab_list + (fun (e, _, _) -> + let i = initiale e in + String.sub e i (min crit_len (String.length e - i))) + (print_elem mode conf base senv is_fam False) liste; + trailer conf; + return () +; + +value afficher_tous_x proj mode is_fam conf base = + let par_frequence = + match p_getenv conf.env "tri" with + [ Some "F" -> True + | _ -> False ] + in + let liste = + let table_x = Mhashtbl.create 801 in + let liste = ref [] in + do for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + let istr = proj p in + let pr = sou base istr in + if pr = "?" then () + else + let compte = + try fst (Mhashtbl.find table_x pr) with + [ Not_found -> + let c = ref 0 in + do Mhashtbl.add table_x pr (c, istr); return c ] + in + incr compte; + done; + Mhashtbl.iter + (fun x (compte, i) -> liste.val := [(x, compte.val, i) :: liste.val]) + table_x; + return + let tri = + if par_frequence then + fun (x, cx, _) (y, cy, _) -> + if cx > cy then True + else if cx < cy then False + else alphabetique x y <= 0 + else fun (x, cx, _) (y, cy, _) -> alphabetique x y <= 0 + in + Sort.list tri liste.val + in + let len = List.length liste in + let senv = if conf.senv = "" then "" else ";e=" ^ conf.senv in + if len >= 50 && p_getenv conf.env "k" <> Some "" then + if par_frequence then + match p_getint conf.env "k" with + [ Some f -> print_frequence mode conf senv base is_fam liste len f + | _ -> print_menu mode conf senv base is_fam liste len par_frequence ] + else + match p_getenv conf.env "k" with + [ Some x -> print_alphab mode conf senv base is_fam liste len x + | _ -> print_menu mode conf senv base is_fam liste len par_frequence ] + else print_all mode conf senv base is_fam liste len par_frequence +; + +value first_alphabetique = + let iv_min = ref 500000 in + let i_min = ref 0 in + do for i = 0 to 255 do + let iv = valeur_alphabetique (Char.chr i) in + if iv < iv_min.val then do iv_min.val := iv; i_min.val := i; return () + else (); + done; + return Char.chr (i_min.val) +; + +value next_alphabetique c = + let v = valeur_alphabetique c in + let iv_min = ref 500000 in + let i_min = ref (-1) in + do for i = 0 to 255 do + let iv = valeur_alphabetique (Char.chr i) in + if iv > v && iv < iv_min.val then + do iv_min.val := iv; i_min.val := i; return () + else (); + done; + return + if i_min.val = -1 then raise Not_found else Char.chr (i_min.val) +; + +value person_has_surname base key ip = + (poi base ip).surname = key +; + +value family_names_print conf base = + afficher_tous_x (fun p -> p.surname) "N" True conf base +; + +value first_names_print conf base = + afficher_tous_x (fun p -> p.first_name) "P" False conf base +; diff --git a/src/argl.ml b/src/argl.ml new file mode 100644 index 0000000000..e22dd95588 --- /dev/null +++ b/src/argl.ml @@ -0,0 +1,99 @@ +(* $Id: argl.ml,v 1.1 1998-09-01 14:32:02 ddr Exp $ *) + +value action_arg s sl = + fun + [ Arg.Unit f -> if s = "" then do f (); return Some sl else None + | Arg.Set r -> if s = "" then do r.val := True; return Some sl else None + | Arg.Clear r -> if s = "" then do r.val := False; return Some sl else None + | Arg.Rest f -> do List.iter f [s :: sl]; return Some [] + | Arg.String f -> + if s = "" then + match sl with + [ [s :: sl] -> do f s; return Some sl + | [] -> None ] + else do f s; return Some sl + | Arg.Int f -> + if s = "" then + match sl with + [ [s :: sl] -> + try do f (int_of_string s); return Some sl with + [ Failure "int_of_string" -> None ] + | [] -> None ] + else + try do f (int_of_string s); return Some sl with + [ Failure "int_of_string" -> None ] + | Arg.Float f -> + if s = "" then + match sl with + [ [s :: sl] -> do f (float_of_string s); return Some sl + | [] -> None ] + else do f (float_of_string s); return Some sl ] +; + +value common_start s1 s2 = + loop 0 where rec loop i = + if i == String.length s1 || i == String.length s2 then i + else if s1.[i] == s2.[i] then loop (i + 1) + else i +; + +value rec parse_arg s sl = + fun + [ [(name, action, _) :: spec_list] -> + let i = common_start s name in + if i == String.length name then + try action_arg (String.sub s i (String.length s - i)) sl action with + [ Arg.Bad _ -> parse_arg s sl spec_list ] + else parse_arg s sl spec_list + | [] -> None ] +; + +value rec parse_aux spec_list anon_fun = + fun + [ [] -> [] + | [s :: sl] -> + if String.length s > 1 && s.[0] = '-' then + match parse_arg s sl spec_list with + [ Some sl -> parse_aux spec_list anon_fun sl + | None -> [s :: parse_aux spec_list anon_fun sl] ] + else do anon_fun s; return parse_aux spec_list anon_fun sl ] +; + +value parse_arg_list spec_list anon_fun remaining_args = + try parse_aux spec_list anon_fun remaining_args with + [ Arg.Bad s -> + do Printf.eprintf "Error: %s\n" s; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 ] +; + +value usage speclist errmsg = + do Printf.printf "%s\n" errmsg; + List.iter (fun (key, _, doc) -> Printf.printf " %s %s\n" key doc) + speclist; + flush stdout; + return () +; + +value parse_list spec_list anonfun errmsg list = + do match parse_arg_list spec_list anonfun list with + [ [] -> () + | ["-help" :: sl] -> + do usage spec_list errmsg; return exit 0 + | [s :: sl] -> + do Printf.eprintf "%s: unknown or misused option\n" s; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 ]; + return () +; + +value parse spec_list anonfun errmsg = + let remaining_args = + List.rev (loop [] (Arg.current.val + 1)) where rec loop l i = + if i == Array.length Sys.argv then l + else loop [Sys.argv.(i) :: l] (i + 1) + in + parse_list spec_list anonfun errmsg remaining_args +; diff --git a/src/ascend.ml b/src/ascend.ml new file mode 100644 index 0000000000..f140c299c3 --- /dev/null +++ b/src/ascend.ml @@ -0,0 +1,880 @@ +(* camlp4r ./def.syn.cmo ./pa_html.cmo *) +(* $Id: ascend.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +value limit_by_list = 8; + +value niveau_max_ascendance base ip = + let x = ref 0 in + let mark = Array.create base.persons.len False in + do let rec loop niveau ip = + if mark.(Adef.int_of_iper ip) then () + else + do mark.(Adef.int_of_iper ip) := True; + x.val := max x.val niveau; + return + match (aoi base ip).parents with + [ Some ifam -> + let cpl = coi base ifam in + do loop (succ niveau) cpl.father; + loop (succ niveau) cpl.mother; + return () + | _ -> () ] + in + loop 0 ip; + return x.val +; + +value text_to conf = + fun + [ 1 -> transl conf "specify" ^ " " ^ transl conf "generation" + | 2 -> transl conf "to the parents" + | 3 -> transl conf "to the grandparents" + | 4 -> transl conf "to the great-grandparents" + | i -> + Printf.sprintf (ftransl conf "to the %s generation") + (transl_nth conf "nth (generation)" i) ] +; + +value text_level conf = + fun + [ 1 -> transl conf "specify" ^ " " ^ transl conf "generation" + | 2 -> transl conf "the parents" + | 3 -> transl conf "the grandparents" + | 4 -> transl conf "the great-grandparents" + | i -> + Printf.sprintf (ftransl conf "the %s generation") + (transl_nth conf "nth (generation)" i) ] +; + +value print_choice conf base p niveau_effectif = + tag "form" "method=get action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n"; + if conf.wizard && conf.friend then + do Wserver.wprint "\n" + (sou base p.surname); + Wserver.wprint "\n" + (sou base p.first_name); + if p.occ > 0 then + Wserver.wprint "\n" p.occ + else (); + return () + else + Wserver.wprint "\n" + (Adef.int_of_iper p.cle_index); + tag "select" "name=v" begin + let rec boucle i = + if i > niveau_effectif + 1 then () + else + do Wserver.wprint "

  • %s\n" + (capitale (transl conf "Sosa numbers")); + Wserver.wprint "
  • %s%t\n" + (capitale (transl conf "list")) + (fun oc -> + if niveau_effectif <= limit_by_list then () + else + do Printf.fprintf oc " ("; + Printf.fprintf oc (ftransl conf "max %d generations") + limit_by_list; + Printf.fprintf oc ")"; + return ()); + Wserver.wprint "
  • %s\n" + (capitale (transl conf "only the generation selected")); + end; + Wserver.wprint "

    \n"; + tag "ul" begin + Wserver.wprint "

  • %s\n" + (capitale (transl conf "missing ancestors")); + Wserver.wprint "
  • %s (%s)\n" + (capitale (transl conf "missing ancestors")) + (transl conf "alphabetic order"); + Wserver.wprint "
    \n"; + Wserver.wprint "%s\n" (capitale (transl conf "after")); + Wserver.wprint "\n"; + Wserver.wprint "%s\n" (capitale (transl conf "before")); + Wserver.wprint "\n"; + end; + Wserver.wprint "

    \n"; + Wserver.wprint "
    \n"; + end +; + +value afficher_menu_ascendants conf base p = + let niveau_effectif = niveau_max_ascendance base p.cle_index in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + print_choice conf base p niveau_effectif; + trailer conf; + return () +; + +value afficher_ancetre conf base x p = + do afficher_personne_referencee conf base p; + Date.afficher_dates_courtes conf base p; + return () +; + +value afficher_ascendants_jusqu_a conf base niveau_max p = + let niveau_max = min limit_by_list niveau_max in + let rec boucle niveau ip = + if niveau < niveau_max then + let x = aoi base ip in + match x.parents with + [ Some ifam -> + let cpl = coi base ifam in + let pere = poi base cpl.father in + let mere = poi base cpl.mother in + let know_fath = connais base pere in + let know_moth = connais base mere in + if know_fath || know_moth then + tag "ul" begin + if know_fath then + do Wserver.wprint "

  • "; + afficher_ancetre conf base p pere; + Wserver.wprint "\n"; + return boucle (succ niveau) cpl.father + else (); + if know_moth then + do Wserver.wprint "
  • "; + afficher_ancetre conf base p mere; + Wserver.wprint "\n"; + return boucle (succ niveau) cpl.mother + else (); + end + else () + | None -> () ] + else () + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + tag "nobr" begin + Wserver.wprint "%s.\n" (capitale (text_to conf niveau_max)); + boucle 1 p.cle_index; + end; + trailer conf; + return () +; + +(* Print ancestors with numbers. + The mark table holds the number of the ancestor after it has been + printed or Num.zero if it has not yet been printed. + At each generation, count and print a list of generation_person *) + +type generation_person = + [ GP_person of Num.t and iper + | GP_same of Num.t and Num.t and iper + | GP_missing of Num.t and iper ] +; + +value next_generation base mark gpl = + let gpl = + List.fold_right + (fun gp gpl -> + match gp with + [ GP_person n ip -> + let n_fath = Num.twice n in + let n_moth = Num.inc n_fath 1 in + let a = aoi base ip in + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + [GP_person n_fath cpl.father; GP_person n_moth cpl.mother :: + gpl] + | None -> [GP_missing n ip :: gpl] ] + | _ -> gpl ]) + gpl [] + in + let gpl = + List.fold_left + (fun gpl gp -> + match gp with + [ GP_person n ip -> + let i = Adef.int_of_iper ip in + let m = mark.(i) in + if Num.eq m Num.zero then do mark.(i) := n; return [gp :: gpl] + else [GP_same n m ip :: gpl] + | _ -> [gp :: gpl] ]) + [] gpl + in + List.rev gpl +; + +value print_generation_person conf base gp = + match gp with + [ GP_person n ip -> + let p = poi base ip in + do Wserver.wprint "
  • "; + Num.print (transl conf "(thousand separator)") n; + Wserver.wprint " -\n"; + afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return () + | GP_same n1 n2 ip -> + let p = poi base ip in + do Wserver.wprint "
  • "; + Num.print (transl conf "(thousand separator)") n1; + Wserver.wprint " => "; + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p) begin + Num.print (transl conf "(thousand separator)") n2; + end; + Wserver.wprint "\n\n"; + return () + | _ -> () ] +; + +value will_print = + fun + [ GP_person _ _ -> True + | GP_same _ _ _ -> True + | _ -> False ] +; + +value afficher_ascendants_numerotation conf base niveau_max p = + let mark = Array.create (base.persons.len) Num.zero in + let rec generation niveau gpl = + if niveau <= niveau_max then + do Wserver.wprint "
  • %s %s\n" + (transl_nth conf "nth (generation)" niveau) + (transl conf "generation"); + tag "ul" begin + List.iter (print_generation_person conf base) gpl; + end; + return + let gpl = next_generation base mark gpl in + if List.exists will_print gpl then generation (niveau + 1) gpl else () + else () + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + Wserver.wprint "%s.\n" (capitale (text_to conf niveau_max)); + tag "ul" begin + mark.(Adef.int_of_iper p.cle_index) := Num.one; + generation 1 [GP_person Num.one p.cle_index]; + end; + trailer conf; + return () +; + +value print_ancestors_same_time_descendants conf base p a = + let maxlen = + match p_getint conf.env "l" with + [ Some len -> len + | None -> -1 ] + in + let predic = + let tab = Array.create base.persons.len False in + let rec mark_descendants len p = + let i = Adef.int_of_iper p.cle_index in + if maxlen > 0 && len > maxlen then () + else if tab.(i) then () + else + do tab.(i) := True; return + for i = 0 to Array.length p.family - 1 do + let fam = foi base p.family.(i) in + for i = 0 to Array.length fam.children - 1 do + mark_descendants (len + 1) (poi base fam.children.(i)); + done; + done + in + do mark_descendants 0 a; return + fun ip -> tab.(Adef.int_of_iper ip) + in + let will_print = + fun + [ GP_person _ ip -> predic ip + | GP_same _ _ _ -> False + | _ -> False ] + in + let mark = Array.create (base.persons.len) Num.zero in + let rec generation niveau gpl = + if List.exists will_print gpl then + do Wserver.wprint "
  • %s %s\n" + (transl_nth conf "nth (generation)" niveau) + (transl conf "generation"); + tag "ul" begin + List.iter + (fun gp -> + if will_print gp then print_generation_person conf base gp + else ()) + gpl; + end; + return + let gpl = next_generation base mark gpl in + generation (niveau + 1) gpl + else () + in + let title h = + if h then + Wserver.wprint "%s... %s..." + (capitale (transl conf "ancestors")) + (transl conf "up to") + else + Wserver.wprint "%s %s %s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text conf base p)) + (transl conf "up to") (person_text conf base a) + in + do header conf title; + conf.senv := ""; + tag "nobr" begin + tag "ul" begin + mark.(Adef.int_of_iper p.cle_index) := Num.one; + generation 1 [GP_person Num.one p.cle_index]; + end; + end; + trailer conf; + return () +; + +value afficher_ascendants_niveau conf base niveau_max p = + let mark = Array.create (base.persons.len) Num.zero in + let rec generation niveau gpl = + do for i = 0 to base.persons.len - 1 do + mark.(i) := Num.zero; + done; + return + if niveau < niveau_max then + generation (niveau + 1) (next_generation base mark gpl) + else + do Wserver.wprint "
  • %s\n" (capitale (text_level conf niveau_max)); + tag "ul" begin + List.iter (print_generation_person conf base) gpl; + end; + return () + in + let title h = + if h then + Wserver.wprint "%s %s\n" + (transl_nth conf "nth (generation)" niveau_max) + (transl conf "generation") + else + Wserver.wprint "%s %s" (capitale (transl conf "ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + tag "nobr" begin + tag "ul" begin + mark.(Adef.int_of_iper p.cle_index) := Num.one; + generation 1 [GP_person Num.one p.cle_index]; + end; + end; + trailer conf; + return () +; + +value print_generation_missing_persons conf base title sp_incl gp = + let print_title () = + match title.val with + [ Some level -> + do Wserver.wprint "
  • %s %s\n" + (transl_nth conf "nth (generation)" level) + (transl conf "generation"); + Wserver.wprint "
      \n"; + title.val := None; + return () + | _ -> () ] + in + match gp with + [ GP_person n ip -> + let p = poi base ip in + if sp_incl && + sou base p.first_name = "?" && sou base p.surname = "?" then + do print_title (); + Wserver.wprint "
    • "; + Num.print (transl conf "(thousand separator)") n; + Wserver.wprint " -\n"; + if Array.length p.family > 0 then + let cpl = coi base p.family.(0) in + let (parent_name_index, conj) = + match p.sexe with + [ Masculin -> (0, cpl.mother) + | _ -> (1, cpl.father) ] + in + do stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p) begin + Wserver.wprint "%s" + (capitale + (transl_nth conf "husband/wife" parent_name_index)); + end; + Wserver.wprint " %s\n" (transl_nth conf "of" 0); + afficher_personne_titre conf base (poi base conj); + Date.afficher_dates_courtes conf base (poi base conj); + return () + else + do afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + return (); + Wserver.wprint "\n"; + return () + else () + | GP_missing n ip -> + let p = poi base ip in + if sou base p.first_name = "?" && sou base p.surname = "?" then () + else + let n1 = Num.twice n in + let n2 = Num.inc n1 1 in + do print_title (); + Wserver.wprint "
    • "; + Num.print (transl conf "(thousand separator)") n1; + Wserver.wprint "-"; + Wserver.wprint "%d" (Num.modl n2 10); + Wserver.wprint " -\n"; + if sp_incl then + Wserver.wprint "%s %s " (capitale (transl conf "parents")) + (transl_nth conf "of" 0) + else (); + afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return () + | _ -> () ] +; + +value one_year base p = + match Adef.od_of_codate p.birth with + [ Some d -> Some (annee d) + | None -> + match Adef.od_of_codate p.baptism with + [ Some d -> Some (annee d) + | None -> + match p.death with + [ Death _ cd -> Some (annee (Adef.date_of_cdate cd)) + | _ -> + match p.burial with + [ Buried cod -> + match Adef.od_of_codate cod with + [ Some d -> Some (annee d) + | None -> None ] + | Cremated cod -> + match Adef.od_of_codate cod with + [ Some d -> Some (annee d) + | None -> None ] + | UnknownBurial -> None ] ] ] ] +; + +value one_year_gp base = + fun + [ GP_person _ ip -> one_year base (poi base ip) + | GP_same _ _ ip -> one_year base (poi base ip) + | GP_missing _ ip -> one_year base (poi base ip) ] +; + +value print_missing_ancestors conf base v spouses_included p = + let after = p_getint conf.env "after" in + let before = p_getint conf.env "before" in + let mark = Array.create (base.persons.len) Num.zero in + let rec generation niveau gpl = + if niveau > v + 1 then () + else if gpl <> [] then + let title = ref (Some niveau) in + let gpl_to_print = + List.fold_left + (fun gpl gp -> + match (after, before) with + [ (Some a1, Some a2) -> + match one_year_gp base gp with + [ Some a -> + if a >= a1 && a <= a2 then [gp :: gpl] + else gpl + | None -> gpl ] + | (Some a1, None) -> + match one_year_gp base gp with + [ Some a -> if a >= a1 then [gp :: gpl] else gpl + | None -> gpl ] + | (None, Some a2) -> + match one_year_gp base gp with + [ Some a -> if a <= a2 then [gp :: gpl] else gpl + | None -> gpl ] + | (None, None) -> [gp :: gpl] ]) + [] gpl + in + do List.iter + (print_generation_missing_persons conf base title spouses_included) + gpl_to_print; + if title.val = None then Wserver.wprint "
    \n" else (); + return + let gpl = next_generation base mark gpl in + generation (niveau + 1) gpl + else () + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "missing ancestors")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "missing ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + Wserver.wprint "%s" (capitale (text_to conf v)); + match after with + [ Some a -> Wserver.wprint " %s %d" (transl conf "after") a + | None -> () ]; + match before with + [ Some a -> Wserver.wprint " %s %d" (transl conf "before") a + | None -> () ]; + Wserver.wprint ".\n"; + mark.(Adef.int_of_iper p.cle_index) := Num.one; + tag "ul" begin + generation 1 [GP_person Num.one p.cle_index]; + end; + trailer conf; + return () +; + +type missing_type = + [ A_person + | A_surname_of_husband_of of string + | A_surname_of_wife_of of string + | A_husband_of + | A_wife_of + | A_parents_of ] +; + +value add_missing conf base spouses_included list = + fun + [ GP_person n ip -> + let p = poi base ip in + if spouses_included && sou base p.first_name = "?" + && sou base p.surname = "?" then + if Array.length p.family > 0 then + let cpl = coi base p.family.(0) in + let (a, p) = + match p.sexe with + [ Masculin -> (A_husband_of, poi base cpl.mother) + | _ -> (A_wife_of, poi base cpl.father) ] + in + [(a, p) :: list] + else [(A_person, p) :: list] + else list + | GP_missing n ip -> + let p = poi base ip in + if spouses_included + && (sou base p.surname = "?" || sou base p.surname = "N..." )then + if sou base p.first_name = "?" then list + else + if Array.length p.family > 0 then + let n = person_text_without_surname conf base p in + let cpl = coi base p.family.(0) in + let (a, p) = + match p.sexe with + [ Masculin -> (A_surname_of_husband_of n, poi base cpl.mother) + | _ -> (A_surname_of_wife_of n, poi base cpl.father) ] + in + if sou base p.surname = "?" then list else [(a, p) :: list] + else [(A_parents_of, p) :: list] + else if sou base p.surname = "?" || sou base p.surname = "?" then + list + else [(A_parents_of, p) :: list] + | _ -> list ] +; + +value val_of_mt = + fun + [ A_person -> 0 + | A_surname_of_husband_of _ -> 1 + | A_surname_of_wife_of _ -> 2 + | A_husband_of -> 3 + | A_wife_of -> 4 + | A_parents_of -> 5 ] +; + +value compare base (mt1, p1) (mt2, p2) = + let c = alphabetique (sou base p1.surname) (sou base p2.surname) in + if c == 0 then + let c = + alphabetique (sou base p1.first_name) (sou base p2.first_name) + in + if c == 0 then + if p1 == p2 then val_of_mt mt1 < val_of_mt mt2 + else + match (Adef.od_of_codate p1.birth, Adef.od_of_codate p2.birth) with + [ (Some d1, Some d2) -> d1 strictement_avant d2 + | _ -> p1.occ < p2.occ ] + else c < 0 + else c > 0 +; + +value print_missing_type conf = + fun + [ A_person -> () + | A_surname_of_husband_of x -> + Wserver.wprint "%s %s %s %s" + (transl_nth conf "surname/surnames" 0) + (transl_nth conf "of" 0) + (transl_nth conf "his wife/her husband" 1) x + | A_surname_of_wife_of x -> + Wserver.wprint "%s %s %s %s" + (transl_nth conf "surname/surnames" 0) + (transl_nth conf "of" 0) + (transl_nth conf "his wife/her husband" 0) x + | A_husband_of -> + Wserver.wprint "%s" (transl_nth conf "husband/wife" 0) + | A_wife_of -> + Wserver.wprint "%s" (transl_nth conf "husband/wife" 1) + | A_parents_of -> + Wserver.wprint "%s" (transl conf "parents") ] +; + +value print_spouses conf base p = + Array.iter + (fun ifam -> + let fam = foi base ifam in + let cpl = coi base ifam in + let sp = poi base (conjoint p cpl) in + if sou base sp.first_name = "?" && sou base sp.surname = "?" then () + else + do (*Wserver.wprint "
    \n    ";*) + Wserver.wprint "\n&"; + match Adef.od_of_codate fam.marriage with + [ Some d -> stag "font" "size=-2" begin Date.display_year d; end + | None -> () ]; + Wserver.wprint "\n"; + afficher_personne_titre conf base sp; + Date.afficher_dates_courtes conf base sp; + return ()) + p.family +; + +value print_someone_missing conf base begin_surname spouses_incl (mt, mtl, p) = + do stag "a" "href=\"%si=%d\"" (commd conf) (Adef.int_of_iper p.cle_index) + begin + Wserver.wprint "%s" (person_text_without_surname conf base p); + end; + Wserver.wprint "%s" begin_surname; + afficher_titre conf base p; + Date.afficher_dates_courtes conf base p; + if spouses_incl then + do Wserver.wprint "\n=> "; + print_missing_type conf mt; + List.iter + (fun mt -> + do Wserver.wprint ", "; + print_missing_type conf mt; + return ()) + mtl; + return () + else + print_spouses conf base p; + return () +; + +value print_alphabetic_missing conf base spouses_included (surname, list) = + do Wserver.wprint "%s " (surname_end surname); + match list with + [ [e] -> + print_someone_missing conf base (surname_begin surname) + spouses_included e + | _ -> + do Wserver.wprint "%s\n" (surname_begin surname); + tag "ul" begin + List.iter + (fun e -> + do Wserver.wprint "
  • "; + print_someone_missing conf base "" spouses_included e; + Wserver.wprint "\n"; + return ()) + list; + end; + return () ]; + return () +; + +value print_missing_ancestors_alphabetically conf base v spouses_included p = + let mark = Array.create (base.persons.len) Num.zero in + let rec generation list niveau gpl = + if niveau > v then list + else if gpl <> [] then + let list = + List.fold_left (add_missing conf base spouses_included) list gpl + in + let gpl = next_generation base mark gpl in + generation list (niveau + 1) gpl + else list + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "missing ancestors")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "missing ancestors")) + (transl_concat conf "of" (person_text conf base p)) + in + let after = p_getint conf.env "after" in + let before = p_getint conf.env "before" in + do header conf title; + let list = generation [] 1 [GP_person Num.one p.cle_index] in + let list = + List.fold_left + (fun npl (n, p) -> + match (after, before) with + [ (Some a1, Some a2) -> + match one_year base p with + [ Some a -> + if a >= a1 && a <= a2 then [(n, p) :: npl] + else npl + | None -> npl ] + | (Some a1, None) -> + match one_year base p with + [ Some a -> if a >= a1 then [(n, p) :: npl] else npl + | None -> npl ] + | (None, Some a2) -> + match one_year base p with + [ Some a -> if a <= a2 then [(n, p) :: npl] else npl + | None -> npl ] + | (None, None) -> [(n, p) :: npl] ]) + [] list + in + let list = Sort.list (compare base) list in + let list = + List.fold_left + (fun nell ((_, p) as elm) -> + match nell with + [ [(n, el) :: nell] when n == sou base p.surname -> + [(n, [elm :: el]) :: nell] + | _ -> [(sou base p.surname, [elm]) :: nell] ]) + [] list + in + let list = + List.map + (fun (n, el) -> + let ell = + List.fold_left + (fun ell ((a, p) as e) -> + match ell with + [ [(a1, al, p1) :: el] when p1 == p -> + [(a, [a1:: al], p) :: el] + | _ -> [(a, [], p) :: ell] ]) + [] el + in + (n, ell)) + list + in + let initials = + List.fold_left + (fun l (n, _) -> + let i = n.[initiale n] in + match l with + [ [] -> [i] + | [x :: l'] -> if x = i then l else [i :: l] ]) + [] list + in + let print_initials = + List.length initials > 3 && List.length list > 100 + in + do if print_initials then + do Wserver.wprint "

    \n"; + List.iter + (fun i -> + do stag "a" "href=\"#%c\"" i begin + Wserver.wprint "%c" i; + end; + Wserver.wprint "\n"; + return ()) + (List.rev initials); + Wserver.wprint "

    \n"; + return () + else (); + Wserver.wprint "%s" (capitale (text_to conf v)); + match after with + [ Some a -> Wserver.wprint " %s %d" (transl conf "after") a + | None -> () ]; + match before with + [ Some a -> Wserver.wprint " %s %d" (transl conf "before") a + | None -> () ]; + Wserver.wprint ".\n"; + tag "ul" begin + let _ = List.fold_left + (fun prev_i ((n, _) as e) -> + let i = n.[initiale n] in + do if print_initials then + match prev_i with + [ Some pi -> + if i <> pi then + do Wserver.wprint "\n"; + Wserver.wprint "

  • %c\n" i i; + Wserver.wprint "
      \n"; + return () + else () + | None -> + do Wserver.wprint "
    • %c\n" i i; + Wserver.wprint "
        \n"; + return () ] + else (); + Wserver.wprint "
      • "; + print_alphabetic_missing conf base spouses_included e; + Wserver.wprint "\n"; + return Some i) + None list + in (); + if print_initials then Wserver.wprint "
      \n" else (); + end; + return (); + trailer conf; + return () +; + +value print conf base p = + match (p_getenv conf.env "t", p_getint conf.env "v") with + [ (Some "L", Some v) -> afficher_ascendants_jusqu_a conf base v p + | (Some "N", Some v) -> afficher_ascendants_numerotation conf base v p + | (Some "S", Some v) -> afficher_ascendants_niveau conf base v p + | (Some "M", Some v) -> + let si = + match p_getenv conf.env "ms" with + [ Some "on" -> True + | _ -> False ] + in + print_missing_ancestors conf base v si p + | (Some "A", Some v) -> + let si = + match p_getenv conf.env "ms" with + [ Some "on" -> True + | _ -> False ] + in + print_missing_ancestors_alphabetically conf base v si p + | (Some "D", Some v) -> + print_ancestors_same_time_descendants conf base p (base.persons.get v) + | _ -> afficher_menu_ascendants conf base p ] +; + +value incorrect_request conf = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "incorrect request")) + in + do header conf title; trailer conf; return () +; diff --git a/src/base64.ml b/src/base64.ml new file mode 100644 index 0000000000..60604ed998 --- /dev/null +++ b/src/base64.ml @@ -0,0 +1,85 @@ +(***********************************************************************) +(* *) +(* The V6 Engine *) +(* *) +(* Francois Rouaix, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: base64.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +(* For basic credentials only *) +(* Encoding is [A-Z][a-z][0-9]+/= *) +(* 3 chars = 24 bits = 4 * 6-bit groups -> 4 chars *) + +value index64 = Array.create 128 0; +(* Init the index *) +do for i = 0 to 25 do index64.(i + Char.code 'A') := i; done; + for i = 0 to 25 do index64.(i + Char.code 'a') := i + 26; done; + for i = 0 to 9 do index64.(i + Char.code '0') := i + 52; done; + index64.(Char.code '+') := 62; +return index64.(Char.code '/') := 63; + +value decode s = + let rpos = ref 0 + and wpos = ref 0 + and len = String.length s in + let res = String.create (len / 4 * 3) in + do while rpos.val < len do + let v1 = index64.(Char.code s.[rpos.val]) in + let v2 = index64.(Char.code s.[rpos.val + 1]) in + let v3 = index64.(Char.code s.[rpos.val + 2]) in + let v4 = index64.(Char.code s.[rpos.val + 3]) in + let i = v1 lsl 18 lor v2 lsl 12 lor v3 lsl 6 lor v4 in + do res.[wpos.val] := Char.chr (i lsr 16); + res.[wpos.val + 1] := Char.chr (i lsr 8 land 0xFF); + res.[wpos.val + 2] := Char.chr (i land 0xFF); + rpos.val := rpos.val + 4; + return wpos.val := wpos.val + 3; + done; + return + let cut = + if s.[len - 1] = '=' then if s.[len - 2] = '=' then 2 else 1 else 0 + in + String.sub res 0 (String.length res - cut) +; + + +value char64 = Array.create 64 'a'; +do for i = 0 to 25 do char64.(i) := Char.chr (Char.code 'A' + i); done; + for i = 0 to 25 do char64.(i + 26) := Char.chr (Char.code 'a' + i); done; + for i = 0 to 9 do char64.(i + 52) := Char.chr (Char.code '0' + i); done; + char64.(62) := '+'; +return char64.(63) := '/'; + +(* Encoding *) +value encode s = + let rpos = ref 0 + and wpos = ref 0 in + let origlen = String.length s in + let (s, len) = + match origlen mod 3 with + [ 0 -> (s, origlen) + | 1 -> (s ^ "\000\000", origlen + 2) + | 2 -> (s ^ "\000", origlen + 1) + | _ -> match () with [] ] + in + let res = String.create (len / 3 * 4) in + do while rpos.val < len do + let i1 = Char.code s.[rpos.val] in + let i2 = Char.code s.[rpos.val + 1] in + let i3 = Char.code s.[rpos.val + 2] in + let i = i1 lsl 16 lor i2 lsl 8 lor i3 in + do res.[wpos.val] := char64.(i lsr 18 land 0x3f); + res.[wpos.val + 1] := char64.(i lsr 12 land 0x3f); + res.[wpos.val + 2] := char64.(i lsr 6 land 0x3f); + res.[wpos.val + 3] := char64.(i land 0x3f); + rpos.val := rpos.val + 3; + return wpos.val := wpos.val + 4; + done; + for i = 1 to len - origlen do res.[String.length res - i] := '='; done; + return res +; diff --git a/src/birth.ml b/src/birth.ml new file mode 100644 index 0000000000..1f0a6d043f --- /dev/null +++ b/src/birth.ml @@ -0,0 +1,87 @@ +(* camlp4r ./def.syn.cmo *) +(* $Id: birth.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +open Def; +open Gutil; +open Util; +open Config; + +value insert_at tab len i p d = + let len = min len (Array.length tab - 1) in + do Array.blit tab i tab (i + 1) (len - i); return + tab.(i) := Some (p, d) +; + +value before d = + fun + [ Some (_, d1) -> d1 strictement_avant d + | _ -> assert False ] +; + +value after d x = not (before d x); + +value insert conf tab len p d = + do assert (len <= Array.length tab); return + if len == 0 then if Array.length tab > 0 then tab.(0) := Some (p, d) else () + else if before d tab.(0) then insert_at tab len 0 p d + else if after d tab.(len - 1) then + if len == Array.length tab then () else tab.(len) := Some (p, d) + else + loop 0 (len - 1) where rec loop imin imax = + do assert (imin < imax); + assert (after d tab.(imin)); + assert (before d tab.(imax)); + return + if imin == imax - 1 then insert_at tab len imax p d + else + let imid = (imin + imax) / 2 in + if before d tab.(imid) then loop imin imid + else loop imid imax +; + +value print conf base = + let n = + match p_getint conf.env "k" with + [ Some x -> x + | _ -> 3 ] + in + let n = min (max 0 n) base.persons.len in + let tab = Array.create n None in + let len = ref 0 in + do for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + if age_autorise conf base p then + match Adef.od_of_codate p.birth with + [ Some d -> + match d with + [ Djma _ _ _ as d -> + do insert conf tab len.val p d; + if len.val == Array.length tab then () else incr len; + return () + | _ -> () ] + | _ -> () ] + else (); + done; + return + let title _ = + Wserver.wprint (fcapitale (ftransl conf "the last %d births")) len.val + in + do header conf title; + Wserver.wprint "
        \n"; + for i = 0 to Array.length tab - 1 do + match tab.(i) with + [ Some (p, d) -> + do Wserver.wprint "

      • \n"; + afficher_personne_referencee conf base p; + Wserver.wprint ",\n"; + Wserver.wprint "%s %s.\n" + (transl_nth conf "born" (index_of_sex p.sexe)) + (Date.string_of_ondate conf d); + Wserver.wprint "

        \n"; + return () + | None -> () ]; + done; + Wserver.wprint "

      \n"; + trailer conf; + return () +; diff --git a/src/birthday.ml b/src/birthday.ml new file mode 100644 index 0000000000..d4199f6ea6 --- /dev/null +++ b/src/birthday.ml @@ -0,0 +1,442 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: birthday.ml,v 1.1 1998-09-01 14:32:09 ddr Exp $ *) + +open Def; +open Config; +open Util; +open Gutil; + +type date_event = [ DeBirth | DeDeath of death_reason ]; + +value afficher_anniversaires_jour conf base dead_people liste = + do Wserver.wprint "
        \n"; + List.iter + (fun (p, a, date_event) -> + let is = index_of_sex p.sexe in + do Wserver.wprint "
      • \n"; + afficher_personne_titre_referencee conf base p; + if not dead_people then Wserver.wprint " %d\n" a + else + let txt = + match date_event with + [ DeBirth -> transl_nth conf "born" is + | DeDeath Unspecified -> transl_nth conf "died" is + | DeDeath Killed -> transl_nth conf "killed (in action)" is + | DeDeath Murdered -> transl_nth conf "murdered" is + | DeDeath Executed -> + transl_nth conf "executed (legally killed)" is + | DeDeath Disappeared -> transl_nth conf "disappeared" is ] + in + Wserver.wprint ", %s %s %d\n" txt + (transl conf "in (year)") a; + return ()) + liste; + Wserver.wprint "
      \n"; + return () +; + +value gen_print conf base mois dead_people = + let tab = Array.create 31 [] in + let title _ = + let lab = + if dead_people then transl conf "anniversaries" + else transl conf "birthdays" + in + Wserver.wprint "%s %s %s" (capitale lab) + (transl conf "in (month year)") + (transl_nth conf "(month)" (mois - 1)) + in + do for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + if not dead_people then + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d, NotDead) -> + match d with + [ Djma j m a -> + if mois == m then + if age_autorise conf base p then + tab.(pred j) := [(p, a, DeBirth) :: tab.(pred j)] + else () + else () + | _ -> () ] + | _ -> () ] + else + match p.death with + [ NotDead | DontKnowIfDead -> () + | _ -> + do match Adef.od_of_codate p.birth with + [ Some d -> + match d with + [ Djma j m a -> + if mois == m then + if age_autorise conf base p then + tab.(pred j) := [(p, a, DeBirth) :: tab.(pred j)] + else () + else () + | _ -> () ] + | _ -> () ]; + match p.death with + [ Death dr d -> + match Adef.date_of_cdate d with + [ Djma j m a -> + if mois == m then + if age_autorise conf base p then + tab.(pred j) := + [(p, a, DeDeath dr) :: tab.(pred j)] + else () + else () + | _ -> () ] + | _ -> () ]; + return () ]; + done; + header conf title; + Wserver.wprint "
        \n"; + for j = 1 to 31 do + if tab.(pred j) <> [] then + do Wserver.wprint "
      • %d\n" j; + let liste = + Sort.list (fun (p1, a1, _) (p2, a2, _) -> a1 <= a2) tab.(pred j) + in + afficher_anniversaires_jour conf base dead_people liste; + return () + else (); + done; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value anniversaire_du conf base dead_people jj mm = + let xx = ref [] in + do for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + if not dead_people then + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d, NotDead) -> + match d with + [ Djma j m a -> + if j == jj && m == mm then + if age_autorise conf base p then + xx.val := [(p, a, DeBirth) :: xx.val] + else () + else () + | _ -> () ] + | _ -> () ] + else + match p.death with + [ NotDead | DontKnowIfDead -> () + | _ -> + do match Adef.od_of_codate p.birth with + [ Some d -> + match d with + [ Djma j m a -> + if j == jj && m == mm then + if age_autorise conf base p then + xx.val := [(p, a, DeBirth) :: xx.val] + else () + else () + | _ -> () ] + | _ -> () ]; + match p.death with + [ Death dr d -> + match Adef.date_of_cdate d with + [ Djma j m a -> + if j == jj && m == mm then + if age_autorise conf base p then + xx.val := [(p, a, DeDeath dr) :: xx.val] + else () + else () + | _ -> () ] + | _ -> () ]; + return () ]; + done; + xx.val := Sort.list (fun (p1, a1, _) (p2, a2, _) -> a1 <= a2) xx.val; + return xx.val +; + +value afficher_liste_anniversaires conf base dead_people a_ref liste = + do Wserver.wprint "
        \n"; + List.iter + (fun (p, a, date_event) -> + do Wserver.wprint "
      • \n"; + if dead_people then + do Wserver.wprint ""; + match date_event with + [ DeBirth -> + Wserver.wprint "%s" (transl conf "of the birth") + | DeDeath (Unspecified | Killed) -> + Wserver.wprint "%s" (transl conf "of the death") + | DeDeath Murdered -> + Wserver.wprint "%s" (transl conf "of the murder") + | DeDeath Executed -> + Wserver.wprint "%s" (transl conf "of the execution") + | DeDeath Disappeared -> + Wserver.wprint "%s" + (transl conf "of the disappearance") ]; + Wserver.wprint "\n"; + Wserver.wprint "%s " (transl_nth conf "of" 0); + afficher_personne_titre_referencee conf base p; + Wserver.wprint "\n%s %d" (transl conf "in (year)") a; + Wserver.wprint " ("; + Wserver.wprint (ftransl conf "%d years ago") + (conf.today_y - a); + Wserver.wprint ")\n"; + return () + else + do afficher_personne_titre_referencee conf base p; + Wserver.wprint " "; + match a_ref - a with + [ 0 -> Wserver.wprint "%s" (transl conf "birth") + | 1 -> Wserver.wprint "%s" (transl conf "one year old") + | n -> Wserver.wprint "%d %s" n (transl conf "years old") ]; + Wserver.wprint ""; + return (); + Wserver.wprint "\n"; + return ()) + liste; + Wserver.wprint "
      \n"; + return () +; + +value print conf base mois = gen_print conf base mois False; +value print_dead conf base mois = gen_print conf base mois True; + +value print_birth_day conf base day_name verb wd d m y list = + match list with + [ [] -> + Wserver.wprint "\n

      \n%s %s.\n" + (capitale (transl conf "no birthday")) day_name + | _ -> + do Wserver.wprint "\n

      \n%s, %s %s%s %s %s:\n" + (capitale day_name) (transl_nth conf "(week day)" wd) + (Date.string_of_date conf (Djma d m y)) verb + (transl conf "the birthday") + (transl_nth conf "of" 0); + afficher_liste_anniversaires conf base False y list; + return () ] +; + +value propose_months conf mode = + tag "form" "method=get action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n" mode; + tag "select" "name=v" begin + for i = 1 to 12 do + Wserver.wprint "\n

      "; + propose_months conf "AN"; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_anniv conf base day_name verb wd d m y list = + match list with + [ [] -> + Wserver.wprint "\n

      \n%s %s.\n" + (capitale (transl conf "no anniversary")) day_name + | _ -> + do Wserver.wprint "\n

      \n%s, %s %s%s %s:" + (capitale day_name) (transl_nth conf "(week day)" wd) + (Date.string_of_date conf (Djma d m y)) verb + (transl conf "the anniversary"); + afficher_liste_anniversaires conf base True y list; + return () ] +; + +value menu_print_dead conf base = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "anniversaries of dead")) + in + do header conf title; + let (tom_d, tom_m, tom_y) = + lendemain (conf.today_d, conf.today_m, conf.today_y) + in + let (aft_d, aft_m, aft_y) = lendemain (tom_d, tom_m, tom_y) in + let list_today = + anniversaire_du conf base True conf.today_d conf.today_m + in + let list_tom = anniversaire_du conf base True tom_d tom_m in + let list_aft = anniversaire_du conf base True aft_d aft_m in + do print_anniv conf base (transl conf "today") (transl conf ", it is") + conf.today_wd conf.today_d conf.today_m conf.today_y list_today; + print_anniv conf base (transl conf "tomorrow") + (transl conf ", it will be") ((conf.today_wd + 1) mod 7) + tom_d tom_m tom_y list_tom; + print_anniv conf base (transl conf "the day after tomorrow") + (transl conf ", it will be") ((conf.today_wd + 2) mod 7) + aft_d aft_m aft_y list_aft; + return (); + Wserver.wprint "\n

      "; + propose_months conf "AD"; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_marriage conf base month = + let title _ = + let lab = transl conf "anniversaries of marriage" in + Wserver.wprint "%s %s %s" (capitale lab) + (transl conf "in (month year)") + (transl_nth conf "(month)" (month - 1)) + in + let tab = Array.create 31 [] in + do header conf title; + for i = 0 to base.families.len - 1 do + let fam = base.families.get i in + if is_deleted_family fam then () + else + match Adef.od_of_codate fam.marriage with + [ Some (Djma d m y) -> + let cpl = base.couples.get i in + if m == month && age_autorise conf base (poi base cpl.father) + && age_autorise conf base (poi base cpl.mother) then + tab.(pred d) := [(cpl, y) :: tab.(pred d)] + else () + | _ -> () ]; + done; + Wserver.wprint "

        "; + for i = 1 to 31 do + match tab.(i - 1) with + [ [] -> () + | l -> + let l = Sort.list (fun (fam1, y1) (fam2, y2) -> y1 < y2) l in + do Wserver.wprint "\n
      • \n"; + Wserver.wprint "%d\n
          " i; + List.iter + (fun (fam, year) -> + do Wserver.wprint "\n
        • \n"; + afficher_personne_titre_referencee conf base + (poi base fam.father); + Wserver.wprint "\n
          %s\n" (transl conf "and"); + afficher_personne_titre_referencee conf base + (poi base fam.mother); + Wserver.wprint ", %s %d\n" + (transl conf "in (year)") year; + return ()) + l; + Wserver.wprint "
        \n"; + return () ]; + done; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value anniversary_of_marriage_of_day conf base dd mm = + let xx = ref [] in + do for i = 0 to base.families.len - 1 do + let fam = base.families.get i in + if is_deleted_family fam then () + else + match Adef.od_of_codate fam.marriage with + [ Some (Djma d m y) -> + let cpl = base.couples.get i in + if age_autorise conf base (poi base cpl.father) + && age_autorise conf base (poi base cpl.mother) + && d == dd && m == mm then xx.val := [(cpl, y) :: xx.val] + else () + | _ -> () ]; + done; + xx.val := Sort.list (fun (fam1, y1) (fam2, y2) -> y1 <= y2) xx.val; + return xx.val +; + +value print_anniversaries_of_marriage conf base y list = + do Wserver.wprint "
        "; + List.iter + (fun (fam, year) -> + do Wserver.wprint "\n
      • \n"; + afficher_personne_titre_referencee conf base + (poi base fam.father); + Wserver.wprint "\n
        %s\n" (transl conf "and"); + afficher_personne_titre_referencee conf base + (poi base fam.mother); + Wserver.wprint ", %s %d\n(" + (transl conf "in (year)") year; + Wserver.wprint (ftransl conf "%d years ago") (conf.today_y - year); + Wserver.wprint ")\n"; + return ()) + list; + Wserver.wprint "
      \n"; + return () +; + +value print_marriage_day conf base day_name verb wd d m y list = + match list with + [ [] -> + Wserver.wprint "\n

      \n%s %s.\n" + (capitale (transl conf "no anniversary")) day_name + | _ -> + do Wserver.wprint "\n

      \n%s, %s %s%s %s %s:\n" + (capitale day_name) (transl_nth conf "(week day)" wd) + (Date.string_of_date conf (Djma d m y)) verb + (transl conf "the anniversary of marriage") + (transl_nth conf "of" 0); + print_anniversaries_of_marriage conf base y list; + return () ] +; + +value print_menu_marriage conf base = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "anniversaries of marriage")) + in + do header conf title; + let (tom_d, tom_m, tom_y) = + lendemain (conf.today_d, conf.today_m, conf.today_y) + in + let (aft_d, aft_m, aft_y) = lendemain (tom_d, tom_m, tom_y) in + let list_today = + anniversary_of_marriage_of_day conf base conf.today_d conf.today_m + in + let list_tomorrow = + anniversary_of_marriage_of_day conf base tom_d tom_m + in + let list_after = + anniversary_of_marriage_of_day conf base aft_d aft_m + in + do print_marriage_day conf base (transl conf "today") + (transl conf ", it is") conf.today_wd conf.today_d conf.today_m + conf.today_y list_today; + print_marriage_day conf base (transl conf "tomorrow") + (transl conf ", it will be") ((conf.today_wd + 1) mod 7) + tom_d tom_m tom_y list_tomorrow; + print_marriage_day conf base (transl conf "the day after tomorrow") + (transl conf ", it will be") ((conf.today_wd + 2) mod 7) + aft_d aft_m aft_y list_after; + return (); + Wserver.wprint "\n

      "; + propose_months conf "AM"; + Wserver.wprint "\n"; + trailer conf; + return () +; diff --git a/src/btree.ml b/src/btree.ml new file mode 100644 index 0000000000..6b044f307c --- /dev/null +++ b/src/btree.ml @@ -0,0 +1,118 @@ +(* $Id: btree.ml,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +module type OrderedType = sig type t = 'a; value compare : t -> t -> int; end; + +module Make (Ord : OrderedType) = + struct + type key = Ord.t; + type t 'a = [ Empty | Node of t 'a and key and 'a and t 'a and int ]; + value empty = Empty; + value height = + fun + [ Empty -> 0 + | Node _ _ _ _ h -> h ] + ; + value create l x d r = + let hl = height l + and hr = height r in + Node l x d r (if hl >= hr then hl + 1 else hr + 1) + ; + value bal l x d r = + let hl = + match l with + [ Empty -> 0 + | Node _ _ _ _ h -> h ] + in + let hr = + match r with + [ Empty -> 0 + | Node _ _ _ _ h -> h ] + in + if hl > hr + 2 then + match l with + [ Empty -> invalid_arg "Map.bal" + | Node ll lv ld lr _ -> + if height ll >= height lr then create ll lv ld (create lr x d r) + else + match lr with + [ Empty -> invalid_arg "Map.bal" + | Node lrl lrv lrd lrr _ -> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) ] ] + else if hr > hl + 2 then + match r with + [ Empty -> invalid_arg "Map.bal" + | Node rl rv rd rr _ -> + if height rr >= height rl then create (create l x d rl) rv rd rr + else + match rl with + [ Empty -> invalid_arg "Map.bal" + | Node rll rlv rld rlr _ -> + create (create l x d rll) rlv rld (create rlr rv rd rr) ] ] + else Node l x d r (if hl >= hr then hl + 1 else hr + 1) + ; + value rec add x data = + fun + [ Empty -> Node Empty x data Empty 1 + | Node l v d r h as t -> + let c = Ord.compare x v in + if c = 0 then Node l x data r h + else if c < 0 then bal (add x data l) v d r + else bal l v d (add x data r) ] + ; + value rec find x = + fun + [ Empty -> raise Not_found + | Node l v d r _ -> + let c = Ord.compare x v in + if c = 0 then d else find x (if c < 0 then l else r) ] + ; + value rec key_after f_compare = + fun + [ Empty -> raise Not_found + | Node l v d r _ -> + let c = f_compare v in + if c < 0 then try key_after f_compare l with [ Not_found -> v ] + else if c > 0 then key_after f_compare r + else v ] + ; + value rec next x = + fun + [ Empty -> raise Not_found + | Node l v d r _ -> + let c = Ord.compare x v in + if c < 0 then try next x l with [ Not_found -> v ] + else next x r ] + ; + value rec merge t1 t2 = + match (t1, t2) with + [ (Empty, t) -> t + | (t, Empty) -> t + | (Node l1 v1 d1 r1 h1, Node l2 v2 d2 r2 h2) -> + bal l1 v1 d1 (bal (merge r1 l2) v2 d2 r2) ] + ; + value rec remove x = + fun + [ Empty -> Empty + | Node l v d r h as t -> + let c = Ord.compare x v in + if c = 0 then merge l r + else if c < 0 then bal (remove x l) v d r + else bal l v d (remove x r) ] + ; + value rec iter f = + fun + [ Empty -> () + | Node l v d r _ -> do iter f l; f v d; return iter f r ] + ; + value rec map f = + fun + [ Empty -> Empty + | Node l v d r h -> Node (map f l) v (f d) (map f r) h ] + ; + value rec fold f m accu = + match m with + [ Empty -> accu + | Node l v d r _ -> fold f l (f v d (fold f r accu)) ] + ; + end +; diff --git a/src/check.ml b/src/check.ml new file mode 100644 index 0000000000..05fac21976 --- /dev/null +++ b/src/check.ml @@ -0,0 +1,247 @@ +(* $Id: check.ml,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +open Def; +open Gutil; + +type gen = + { g_strings : mutable Mhashtbl.t string istr; + g_names : mutable Mhashtbl.t int iper; + g_pcnt : mutable int; + g_fcnt : mutable int; + g_scnt : mutable int; + g_base : base; + g_def : mutable array bool; + g_shift : mutable int; + g_errored : mutable bool } +; + +value error gen = gen.g_errored := True; + +value feminin = + fun + [ Masculin -> "" + | Feminin -> "e" + | Neutre -> "(e)" ] +; + +value glop x = + let y = String.create (String.length x) in + do for i = 0 to String.length x - 1 do + y.[i] := if x.[i] == ' ' then '_' else x.[i]; + done; + return y +; + +value print_base_error base = + fun + [ AlreadyDefined p -> + Printf.eprintf "%s\nis defined several times\n" (denomination base p) + | OwnAncestor p -> + Printf.eprintf "%s\nis his/her own ancestor\n" (denomination base p) + | BadSexOfMarriedPerson p -> + Printf.eprintf "%s\n bad sex (this error should not have occurred)\n" + (denomination base p) ] +; + +value print_base_warning base = + fun + [ BirthAfterDeath p -> + Printf.eprintf "%s\n born after his/her death\n" (denomination base p) + | ChangedOrderOfChildren fam _ -> + let cpl = coi base fam.fam_index in + Printf.eprintf "changed order of children of %s and %s\n" + (denomination base (poi base cpl.father)) + (denomination base (poi base cpl.mother)) + | ChildrenNotInOrder fam elder x -> + let cpl = coi base fam.fam_index in + do Printf.eprintf + "the following children of\n %s\nand\n %s\nare not in order:\n" + (denomination base (poi base cpl.father)) + (denomination base (poi base cpl.mother)); + Printf.eprintf "- %s\n" (denomination base elder); + Printf.eprintf "- %s\n" (denomination base x); + return () + | DeadTooEarlyToBeFather father child -> + do Printf.eprintf "%s\n" (denomination base child); + Printf.eprintf + " is born more than 2 years after the death of his/her father\n"; + Printf.eprintf "%s\n" (denomination base father); + return () + | MarriageDateAfterDeath p -> + do Printf.eprintf "%s\n" (denomination base p); + Printf.eprintf "married after his/her death\n"; + return () + | MarriageDateBeforeBirth p -> + do Printf.eprintf "%s\n" (denomination base p); + Printf.eprintf "married before his/her birth\n"; + return () + | MotherDeadAfterChildBirth mother child -> + Printf.eprintf "%s\n is born after the death of his/her mother\n%s\n" + (denomination base child) (denomination base mother) + | ParentBornAfterChild parent child -> + Printf.eprintf "%s born after his/her child %s\n" + (denomination base parent) (denomination base child) + | ParentTooYoung p a -> + Printf.eprintf "%s was parent at age of %d\n" (denomination base p) + (annee a) + | TitleDatesError p t -> + do Printf.eprintf "%s\n" (denomination base p); + Printf.eprintf "has incorrect title dates as:\n"; + Printf.eprintf " %s %s\n" (sou base t.t_title) (sou base t.t_place); + return () + | YoungForMarriage p a -> + Printf.eprintf "%s married at age %d\n" (denomination base p) (annee a) ] +; + +value set_error base gen x = + do Printf.eprintf "\nError: "; + print_base_error base x; + error gen; + return () +; + +value set_warning base x = + do Printf.eprintf "\nWarning: "; + print_base_warning base x; + return () +; + +type stats = + {men : mutable int; + women : mutable int; + neutre : mutable int; + noname : mutable int; + oldest_father : mutable (int * base_person); + oldest_mother : mutable (int * base_person); + youngest_father : mutable (int * base_person); + youngest_mother : mutable (int * base_person); + oldest_dead : mutable (int * base_person); + oldest_still_alive : mutable (int * base_person)} +; + +value birth_year p = + match Adef.od_of_codate p.birth with + [ Some d -> + match d with + [ Da Sure y -> Some y + | Dma _ y -> Some y + | Djma _ _ y -> Some y + | _ -> None ] + | _ -> None ] +; + +value death_year current_year p = + match p.death with + [ Death _ d -> + match Adef.date_of_cdate d with + [ Da Sure y -> Some y + | Dma _ y -> Some y + | Djma _ _ y -> Some y + | _ -> None ] + | NotDead -> Some current_year + | _ -> None ] +; + +value update_stats base current_year s p = + do match p.sexe with + [ Masculin -> s.men := s.men + 1 + | Feminin -> s.women := s.women + 1 + | Neutre -> s.neutre := s.neutre + 1 ]; + if sou base p.first_name = "?" && sou base p.surname = "?" then + s.noname := s.noname + 1 + else (); + match (birth_year p, death_year current_year p) with + [ (Some y1, Some y2) -> + let age = y2 - y1 in + do if age > fst s.oldest_dead && p.death <> NotDead then + s.oldest_dead := (age, p) + else (); + if age > fst s.oldest_still_alive && p.death = NotDead then + s.oldest_still_alive := (age, p) + else (); + return () + | _ -> () ]; + match (birth_year p, (aoi base p.cle_index).parents) with + [ (Some y2, Some ifam) -> + let cpl = coi base ifam in + do match birth_year (poi base cpl.father) with + [ Some y1 -> + let age = y2 - y1 in + do if age > fst s.oldest_father then + s.oldest_father := (age, poi base cpl.father) + else (); + if age < fst s.youngest_father then + s.youngest_father := (age, poi base cpl.father) + else (); + return () + | _ -> () ]; + match birth_year (poi base cpl.mother) with + [ Some y1 -> + let age = y2 - y1 in + do if age > fst s.oldest_mother then + s.oldest_mother := (age, poi base cpl.mother) + else (); + if age < fst s.youngest_father then + s.youngest_mother := (age, poi base cpl.mother) + else (); + return () + | _ -> () ]; + return () + | _ -> () ]; + return () +; + +(* the parameter "gen" should disapear while changing along the functions + called by check_base which should use now "base" instead of "gen" *) + +value check_base base gen pr_stats = + let s = + let y = (1000, base.persons.get 0) in + let o = (0, base.persons.get 0) in + {men = 0; women = 0; neutre = 0; noname = 0; + oldest_father = o; oldest_mother = o; youngest_father = y; + youngest_mother = y; oldest_dead = o; oldest_still_alive = o} + in + let current_year = (Unix.localtime (Unix.time ())).Unix.tm_year + 1900 in + do Gutil.check_base base (set_error base gen) (set_warning base); + for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + do if not gen.g_def.(i) then + Printf.eprintf "Undefined: %s%s %s\n" + (sou base p.first_name) + (if p.occ == 0 then "" else "." ^ string_of_int p.occ) + (glop (sou base p.surname)) + else (); + if pr_stats then update_stats base current_year s p else (); + return (); + flush stderr; + done; + if pr_stats then + do Printf.printf "\n"; + Printf.printf "%d men\n" s.men; + Printf.printf "%d women\n" s.women; + Printf.printf "%d unknown sex\n" s.neutre; + Printf.printf "%d unnamed\n" s.noname; + Printf.printf "Oldest: %s, %d\n" + (denomination base (snd s.oldest_dead)) (fst s.oldest_dead); + Printf.printf "Oldest still alive: %s, %d\n" + (denomination base (snd s.oldest_still_alive)) + (fst s.oldest_still_alive); + Printf.printf "Youngest father: %s, %d\n" + (denomination base (snd s.youngest_father)) + (fst s.youngest_father); + Printf.printf "Youngest mother: %s, %d\n" + (denomination base (snd s.youngest_mother)) + (fst s.youngest_mother); + Printf.printf "Oldest father: %s, %d\n" + (denomination base (snd s.oldest_father)) + (fst s.oldest_father); + Printf.printf "Oldest mother: %s, %d\n" + (denomination base (snd s.oldest_mother)) + (fst s.oldest_mother); + Printf.printf "\n"; + flush stdout; + return () + else (); + return () +; diff --git a/src/config.mli b/src/config.mli new file mode 100644 index 0000000000..476775a724 --- /dev/null +++ b/src/config.mli @@ -0,0 +1,23 @@ +(* $Id: config.mli,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Def; + +type config = + { wizard : bool; + friend : bool; + cgi : bool; + command : string; + lang : string; + bname : string; + env : list (string * string); + senv : mutable string; + henv : mutable list (string * string); + base_env : list (string * string); + request : list string; + lexicon : Hashtbl.t string string; + today : date; + today_d : int; + today_m : int; + today_y : int; + today_wd : int } +; diff --git a/src/consang.ml b/src/consang.ml new file mode 100644 index 0000000000..0664fbba32 --- /dev/null +++ b/src/consang.ml @@ -0,0 +1,236 @@ +(* $Id: consang.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +(* Algorithm relationship and links from Didier Remy *) + +open Check; +open Def; +open Gutil; + +type relationship = + { weight1 : mutable float; + weight2 : mutable float; + relationship : mutable float; + lens1 : mutable list (int * int); + lens2 : mutable list (int * int); + elim_ancestors : mutable bool; + mark : mutable int } +; + +type relationship_table = + { id : array int; + info : array relationship } +; + +value no_consang = Adef.fix (-1); + +value half x = x *. 0.5; + +value mark = ref 0; +value new_mark () = do incr mark; return mark.val; + +value topological_sort base = + let tab = Array.create base.persons.len 0 in + let todo = ref [] in + let cnt = ref 0 in + do for i = 0 to base.persons.len - 1 do + let a = base.ascends.get i in + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + let ifath = Adef.int_of_iper cpl.father in + let imoth = Adef.int_of_iper cpl.mother in + do tab.(ifath) := tab.(ifath) + 1; + tab.(imoth) := tab.(imoth) + 1; + return () + | _ -> () ]; + done; + for i = 0 to base.persons.len - 1 do + if tab.(i) == 0 then todo.val := [i :: todo.val] else (); + done; + loop todo.val where rec loop = + fun + [ [i :: il] -> + let a = base.ascends.get i in + do todo.val := il; + tab.(i) := cnt.val; + incr cnt; + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + let ifath = Adef.int_of_iper cpl.father in + let imoth = Adef.int_of_iper cpl.mother in + do tab.(ifath) := tab.(ifath) - 1; + tab.(imoth) := tab.(imoth) - 1; + if tab.(ifath) == 0 then todo.val := [ifath :: todo.val] + else (); + if tab.(imoth) == 0 then todo.val := [imoth :: todo.val] + else (); + return () + | _ -> () ]; + return loop todo.val + | [] -> () ]; + if cnt.val <> base.persons.len then + failwith + ("topological sort: cnt " ^ string_of_int cnt.val ^ " len " ^ + string_of_int base.persons.len) + else (); + return tab +; + +value make_relationship_table base = + let id = topological_sort base in + let phony = + {weight1 = 0.0; weight2 = 0.0; relationship = 0.0; lens1 = []; lens2 = []; + mark = 0; elim_ancestors = False} + in + let tab = Array.create base.persons.len phony in + {id = id; info = tab} +; + +value rec insert_branch_len_rec (len, n) = + fun + [ [] -> [(len, n)] + | [(len1, n1) :: lens] -> + if len == len1 then [(len1, n + n1) :: lens] + else [(len1, n1) :: insert_branch_len_rec (len, n) lens] ] +; + +value rec insert_branch_len lens (len, n) = + insert_branch_len_rec (succ len, n) lens +; + +value consang_of p = + if p.consang == no_consang then 0.0 else Adef.float_of_fix p.consang +; + +value leq = ref (fun []); +module Pq = + Pqueue.Make (struct type t = int; value leq x y = leq.val x y; end) +; + +value relationship_and_links base {id = id; info = tab} b ip1 ip2 = + let i1 = Adef.int_of_iper ip1 in + let i2 = Adef.int_of_iper ip2 in + if i1 == i2 then (1.0, []) + else + let reset u mark = + tab.(u) := + {weight1 = 0.0; weight2 = 0.0; relationship = 0.0; lens1 = []; + lens2 = []; mark = mark; elim_ancestors = False} + in + do leq.val := fun x y -> id.(x) < id.(y); return + let q = ref Pq.empty in + let inserted = new_mark () in + let add u = do reset u inserted; q.val := Pq.add u q.val; return () in + let relationship = ref 0.0 in + let tops = ref [] in + let treat u y = + do if tab.(y).mark <> inserted then add y else (); return + let ty = tab.(y) in + let p1 = half u.weight1 in + let p2 = half u.weight2 in + do ty.weight1 := ty.weight1 +. p1; + ty.weight2 := ty.weight2 +. p2; + ty.relationship := ty.relationship +. p1 *. p2; + if u.elim_ancestors then ty.elim_ancestors := True else (); + if b && not ty.elim_ancestors then + do ty.lens1 := + List.fold_left insert_branch_len ty.lens1 u.lens1; + ty.lens2 := + List.fold_left insert_branch_len ty.lens2 u.lens2; + return () + else (); + return () + in + do add i1; + add i2; + tab.(i1).weight1 := 1.0; + tab.(i2).weight2 := 1.0; + tab.(i1).lens1 := [(0, 1)]; + tab.(i2).lens2 := [(0, 1)]; + while not (Pq.is_empty q.val) do + let (u, nq) = Pq.take q.val in + do q.val := nq; return + let tu = tab.(u) in + let a = base.ascends.get u in + let contribution = + tu.weight1 *. tu.weight2 -. + tu.relationship *. (1.0 +. consang_of a) + in + do relationship.val := relationship.val +. contribution; + if b && contribution <> 0.0 && not tu.elim_ancestors then + do tops.val := [u :: tops.val]; + tu.elim_ancestors := True; + return () + else (); + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + do treat tu (Adef.int_of_iper cpl.father); + treat tu (Adef.int_of_iper cpl.mother); + return () + | _ -> () ]; + return (); + done; + return (half relationship.val, tops.val) +; + +value relationship base tab ip1 ip2 = + fst (relationship_and_links base tab False ip1 ip2) +; + +value compute_all_consang base from_scratch = + let _ = base.ascends.array () in + let _ = base.couples.array () in + let _ = base.families.array () in + do Printf.eprintf "Computing consanguinity..."; flush stderr; return + let running = ref True in + let tab = make_relationship_table base in + let cnt = ref 0 in + let most = ref (base.ascends.get 0) in + do for i = 0 to base.ascends.len - 1 do + let a = base.ascends.get i in + do if from_scratch then a.consang := no_consang else (); return + if a.consang == no_consang then incr cnt else (); + done; + while running.val do + running.val := False; + for i = 0 to base.ascends.len - 1 do + let a = base.ascends.get i in + if a.consang == no_consang then + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + let fath = aoi base cpl.father in + let moth = aoi base cpl.mother in + if fath.consang != no_consang && moth.consang != no_consang then + let consang = relationship base tab cpl.father cpl.mother in + let fam = foi base ifam in + for i = 0 to Array.length fam.children - 1 do + let ip = fam.children.(i) in + let a = aoi base ip in + do Printf.eprintf "%6d\008\008\008\008\008\008" cnt.val; + flush stderr; + decr cnt; + a.consang := Adef.fix_of_float consang; + if a.consang > most.val.consang then + do Printf.eprintf "\nMax consanguinity %g for %s... " + consang (denomination base (poi base ip)); + flush stderr; + return most.val := a + else (); + return (); + done + else running.val := True + | None -> + do Printf.eprintf "%6d\008\008\008\008\008\008" cnt.val; + flush stderr; + decr cnt; + return a.consang := Adef.fix_of_float 0.0 ] + else (); + done; + done; + Printf.eprintf " done \n"; + flush stderr; + return () +; diff --git a/src/date.ml b/src/date.ml new file mode 100644 index 0000000000..959f2b6045 --- /dev/null +++ b/src/date.ml @@ -0,0 +1,150 @@ +(* $Id: date.ml,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Def; +open Util; +open Gutil; + +value nbsp = " "; + +value string_of_ondate conf d = + match d with + [ Djma d m y -> + transl conf "on (day month year)" ^ nbsp ^ + transl_nth conf "(day)" (d - 1) ^ nbsp ^ + transl_nth conf "(month)" (m - 1) ^ nbsp ^ string_of_int y + | Dma m y -> + transl conf "in (month year)" ^ nbsp ^ + transl_nth conf "(month)" (m - 1) ^ nbsp ^ string_of_int y + | Da Sure y -> transl conf "in (year)" ^ nbsp ^ string_of_int y + | Da About y -> transl conf "about (year)" ^ nbsp ^ string_of_int y + | Da Maybe y -> transl conf "maybe in (year)" ^ nbsp ^ string_of_int y + | Da Before y -> transl conf "before (year)" ^ nbsp ^ string_of_int y + | Da After y -> transl conf "after (year)" ^ nbsp ^ string_of_int y + | Da (OrYear z) y -> + transl conf "in (year)" ^ nbsp ^ string_of_int y ^ nbsp ^ + transl conf "or" ^ nbsp ^ string_of_int z ] +; + +value string_of_date conf d = + match d with + [ Djma d m y -> + transl_nth conf "(day)" (d - 1) ^ " " ^ + transl_nth conf "(month)" (m - 1) ^ " " ^ string_of_int y + | Dma m y -> + transl_nth conf "(month)" (m - 1) ^ " " ^ string_of_int y + | Da Sure y -> string_of_int y + | Da _ _ -> "..." ] +; + +value print_age conf a = + match a with + [ Djma d m y -> + if y >= 2 then + Wserver.wprint "%d %s" y (transl conf "years old") + else if y > 0 || m > 1 then + Wserver.wprint "%d %s" (y * 12 + m) (transl conf "months old") + else if m = 1 then + Wserver.wprint "%s" (transl conf "one month old") + else if d >= 2 then + Wserver.wprint "%d %s" d (transl conf "days old") + else if d == 1 then + Wserver.wprint "%s" (transl conf "one day old") + else Wserver.wprint "0" + | Dma m y -> + if y >= 2 then + Wserver.wprint "%d %s" y (transl conf "years old") + else if y > 0 || m > 1 then + Wserver.wprint "%d %s" (y * 12 + m) (transl conf "months old") + else if m = 1 then + Wserver.wprint "%s" (transl conf "one month old") + else + Wserver.wprint "%s" (transl conf "less than one month old") + | Da _ y -> + if y > 1 then + Wserver.wprint "%d %s" y (transl conf "years old") + else if y = 1 then + Wserver.wprint "%s" (transl conf "one year old") + else + Wserver.wprint "%s" (transl conf "less than one year old") ] +; + +value afficher_dates conf base p = + let is = index_of_sex p.sexe in + if age_autorise conf base p then + let something = + match (Adef.od_of_codate p.birth, p.death) with + [ (Some _, _) + | (_, Death _ _ | DeadYoung | DeadDontKnowWhen) -> True + | _ -> False ] + in + do if something then Wserver.wprint "" else (); + match Adef.od_of_codate p.birth with + [ Some d -> + do Wserver.wprint ",\n%s\n" (transl_nth conf "born" is); + Wserver.wprint "%s" (string_of_ondate conf d); + return () + | None -> () ]; + match p.death with + [ Death dr d -> + let d = Adef.date_of_cdate d in + let dr_w = + match dr with + [ Unspecified -> transl_nth conf "died" is + | Murdered -> transl_nth conf "murdered" is + | Killed -> transl_nth conf "killed (in action)" is + | Executed -> transl_nth conf "executed (legally killed)" is + | Disappeared -> transl_nth conf "disappeared" is ] + in + do Wserver.wprint ",\n%s\n" dr_w; + Wserver.wprint "%s" (string_of_ondate conf d); + return () + | DeadYoung -> + Wserver.wprint ",\n%s" (transl_nth conf "dead young" is) + | DeadDontKnowWhen | DontKnowIfDead | NotDead -> () ]; + if something then Wserver.wprint "" else (); + return () + else () +; + +value display_year d = + do match d with + [ Da Before _ -> Wserver.wprint "/" + | Da (About | Maybe | OrYear _) _ -> Wserver.wprint "ca " + | _ -> () ]; + Wserver.wprint "%d" (annee d); + match d with + [ Da After _ -> Wserver.wprint "/" + | _ -> () ]; + return () +; + +value afficher_dates_courtes conf base p = + if age_autorise conf base p then + let something = + match (Adef.od_of_codate p.birth, p.death) with + [ (Some _, _) | (_, Death _ _) -> True + | _ -> False ] + in + if something then + do Wserver.wprint " "; + match (Adef.od_of_codate p.birth, p.death) with + [ (Some _, DeadDontKnowWhen | DontKnowIfDead) -> + Wserver.wprint "*" + | _ -> () ]; + match Adef.od_of_codate p.birth with + [ Some d -> display_year d + | _ -> () ]; + match (Adef.od_of_codate p.birth, p.death) with + [ (Some _, Death _ _ | NotDead) -> Wserver.wprint "-" + | (_, Death _ _) -> Wserver.wprint "+" + | _ -> () ]; + match p.death with + [ Death _ d -> + let d = Adef.date_of_cdate d in + display_year d + | _ -> () ]; + Wserver.wprint ""; + return () + else () + else () +; diff --git a/src/def.mli b/src/def.mli new file mode 100644 index 0000000000..d0b19ce74a --- /dev/null +++ b/src/def.mli @@ -0,0 +1,133 @@ +(* $Id: def.mli,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +type iper = Adef.iper; +type ifam = Adef.ifam; +type istr = Adef.istr; +type cdate = Adef.cdate; +type codate = Adef.codate; + +type precision = Adef.precision == + [ Sure | About | Maybe | Before | After | OrYear of int ] +; +type date = Adef.date == + [ Djma of int and int and int + | Dma of int and int + | Da of precision and int ] +; + +type divorce = [ NotDivorced | Divorced of codate ]; + +type death_reason = + [ Killed | Murdered | Executed | Disappeared | Unspecified ] +; +type death = + [ NotDead + | Death of death_reason and cdate + | DeadYoung + | DeadDontKnowWhen + | DontKnowIfDead ] +; + +type burial = [ UnknownBurial | Buried of codate | Cremated of codate ]; + +type access = [ IfTitles | Public | Private ]; + +type title_name 'string = [ Tmain | Tname of 'string | Tnone ]; +type title 'string = + { t_name : mutable title_name 'string; + t_title : mutable 'string; + t_place : mutable 'string; + t_date_start : mutable codate; + t_date_end : mutable codate; + t_nth : mutable int } +; + +type sexe = [ Masculin | Feminin | Neutre ]; + +type person 'string = + { first_name : mutable 'string; + surname : mutable 'string; + occ : mutable int; + photo : mutable 'string; + public_name : mutable 'string; + nick_names : mutable list 'string; + aliases : mutable list 'string; + first_names_aliases : mutable list 'string; + surnames_aliases : mutable list 'string; + titles : mutable list (title 'string); + occupation : mutable 'string; + sexe : mutable sexe; + access : mutable access; + birth : mutable codate; + birth_place : mutable 'string; + baptism : mutable codate; + baptism_place : mutable 'string; + death : mutable death; + death_place : mutable 'string; + burial : mutable burial; + burial_place : mutable 'string; + family : mutable array ifam; + notes : mutable 'string; + psources : mutable 'string; + cle_index : mutable iper } +; + +type ascend = + { parents : mutable option ifam; + consang : mutable Adef.fix } +; + +type family 'person 'string = + { marriage : mutable codate; + marriage_place : mutable 'string; + divorce : mutable divorce; + children : mutable array 'person; + comment : mutable 'string; + origin_file : mutable 'string; + fsources : mutable 'string; + fam_index : mutable ifam } +; + +type couple 'person = + { father : mutable 'person; + mother : mutable 'person } +; + +type base_person = person istr; +type base_ascend = ascend; +type base_family = family iper istr; +type base_couple = couple iper; + +type cache 'a = + { array : mutable unit -> array 'a; + get : mutable int -> 'a; + len : mutable int } +; + +type istr_iper_index = + { find : istr -> list iper; + cursor : string -> istr; + next : istr -> istr } +; + +type base = + { persons : cache base_person; + ascends : cache base_ascend; + families : cache base_family; + couples : cache base_couple; + strings : cache string; + has_family_patches : bool; + persons_of_name : string -> list iper; + strings_of_fsname : string -> list istr; + index_of_string : string -> istr; + persons_of_surname : istr_iper_index; + persons_of_first_name : istr_iper_index; + patch_person : iper -> base_person -> unit; + patch_ascend : iper -> base_ascend -> unit; + patch_family : ifam -> base_family -> unit; + patch_couple : ifam -> base_couple -> unit; + patch_string : istr -> string -> unit; + patch_name : string -> iper -> unit; + commit_patches : unit -> unit; + cleanup : unit -> unit } +; diff --git a/src/def.syn.ml b/src/def.syn.ml new file mode 100644 index 0000000000..8473aa587b --- /dev/null +++ b/src/def.syn.ml @@ -0,0 +1,16 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: def.syn.ml,v 1.1 1998-09-01 14:32:02 ddr Exp $ *) + +open Pcaml; + +EXTEND + expr: BEFORE "<" + [ [ x = expr; "strictement_avant"; y = expr -> + <:expr< strictement_avant $x$ $y$ >> + | x = expr; "strictement_apres"; y = expr -> + <:expr< strictement_apres $x$ $y$ >> + | x = expr; "avant"; y = expr -> + <:expr< not (strictement_apres $x$ $y$) >> + | x = expr; "apres"; y = expr -> + <:expr< not (strictement_avant $x$ $y$) >> ] ]; +END; diff --git a/src/descend.ml b/src/descend.ml new file mode 100644 index 0000000000..53273a2d35 --- /dev/null +++ b/src/descend.ml @@ -0,0 +1,950 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: descend.ml,v 1.1 1998-09-01 14:32:10 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +value limit_by_list = 8; + +value infini = 10000; + +value make_level_table base niveau_max p = + let mark = Array.create (base.persons.len) False in + let levt = Array.create (base.persons.len) infini in + let rec fill p lev = + if niveau_max == infini && mark.(Adef.int_of_iper p.cle_index) then () + else + do mark.(Adef.int_of_iper p.cle_index) := True; return + if lev <= niveau_max then + do if lev < levt.(Adef.int_of_iper p.cle_index) then + levt.(Adef.int_of_iper p.cle_index) := lev + else (); + return + Array.iter + (fun ifam -> + let pl = (foi base ifam).children in + Array.iter (fun p -> fill (poi base p) (succ lev)) pl) + p.family + else () + in + do fill p 0; return levt +; + +value level_max base p = + let levt = make_level_table base infini p in + let x = ref 0 in + do for i = 0 to Array.length levt - 1 do + let lev = levt.(i) in + if lev != infini && x.val < lev then x.val := lev else (); + done; + return x.val +; + +value text_to conf = + fun + [ 0 -> transl conf "specify" ^ " " ^ transl conf "generation" + | 1 -> transl conf "to the children" + | 2 -> transl conf "to the grandchildren" + | 3 -> transl conf "to the great-grandchildren" + | i -> + Printf.sprintf (ftransl conf "to the %s generation") + (transl_nth conf "nth (generation)" i) ] +; + +value text_level conf = + fun + [ 0 -> transl conf "specify" ^ " " ^ transl conf "generation" + | 1 -> transl conf "the children" + | 2 -> transl conf "the grandchildren" + | 3 -> transl conf "the great-grandchildren" + | i -> + Printf.sprintf (ftransl conf "the %s generation") + (transl_nth conf "nth (generation)" i) ] +; + +value print_choice conf base p niveau_effectif = + tag "form" "method=get action=\"%s\"" conf.command begin + List.iter + (fun (k, v) -> + Wserver.wprint "\n" k v) + conf.henv; + Wserver.wprint "\n"; + if conf.wizard && conf.friend && sou base p.surname <> "?" + && sou base p.first_name <> "?" then + do Wserver.wprint "\n" + (sou base p.surname); + Wserver.wprint "\n" + (sou base p.first_name); + if p.occ > 0 then + Wserver.wprint "\n" p.occ + else (); + return () + else + Wserver.wprint "\n" + (Adef.int_of_iper p.cle_index); + tag "select" "name=v" begin + let rec boucle i = + if i > niveau_effectif then () + else + do Wserver.wprint "

    • %s%t\n" + (capitale (transl conf "list")) + (fun oc -> + if niveau_effectif <= limit_by_list then () + else + do Printf.fprintf oc " ("; + Printf.fprintf oc (ftransl conf "max %d generations") + limit_by_list; + Printf.fprintf oc ")"; + return ()); + Wserver.wprint "
    • %s\n" + (capitale (transl conf "families with encoding")); + Wserver.wprint "
    • -> %s\n" + (capitale (transl conf "index of the descendants")); + Wserver.wprint "
    • -> %s\n" + (capitale (transl conf "index of the spouses (non descendants)")); + Wserver.wprint "
    • %s\n" + (capitale (transl conf "only the generation selected")); + end; + Wserver.wprint "
      \n"; + end +; + +value afficher_menu_descendants conf base p = + let niveau_effectif = level_max base p in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; + print_choice conf base p niveau_effectif; + trailer conf; + return () +; + +value s_appelle_comme_son_pere base ip = + let a = aoi base ip in + match a.parents with + [ Some ifam -> + (poi base ip).surname = (poi base (coi base ifam).father).surname + | _ -> False ] +; + +value afficher_marie conf base first fam p conjoint = + let is = index_of_sex p.sexe in + do stag "em" begin + Wserver.wprint + (ftransl_nth conf "allied%t (euphemism for married or... not) to" is) + (fun _ -> + if age_autorise conf base p && age_autorise conf base conjoint then + let marriage = Adef.od_of_codate fam.marriage in + let marriage_place = sou base fam.marriage_place in + do match (marriage, marriage_place) with + [ (None, "") -> () + | _ -> Wserver.wprint "\n" ]; + match marriage with + [ Some d -> Wserver.wprint "%s" (Date.string_of_ondate conf d) + | _ -> () ]; + match marriage_place with + [ "" -> () + | s -> Wserver.wprint " - %s, " s ]; + return () + else ()); + end; + Wserver.wprint "\n"; + stag "strong" begin + afficher_personne_referencee conf base conjoint; + end; + Date.afficher_dates conf base conjoint; + if age_autorise conf base p && age_autorise conf base conjoint then + match fam.divorce with + [ NotDivorced -> () + | Divorced cod -> + do Wserver.wprint ",\n"; + stag "em" begin + Wserver.wprint "%s" (transl conf "divorced"); + match Adef.od_of_codate cod with + [ Some d -> Wserver.wprint " %s" (Date.string_of_ondate conf d) + | None -> () ]; + end; + return () ] + else (); + return () +; + +value print_child conf base levt boucle niveau_max niveau compte ix = + let x = poi base ix in + do Wserver.wprint "
    • "; + stag "strong" begin + if s_appelle_comme_son_pere base ix then + afficher_prenom_de_personne_referencee conf base x + else afficher_personne_referencee conf base x; + end; + Date.afficher_dates conf base x; + if levt.(Adef.int_of_iper x.cle_index) < niveau then + Wserver.wprint ", %s" + (transl conf "see further") + else if + levt.(Adef.int_of_iper x.cle_index) > niveau then + Wserver.wprint ", %s" + (transl conf "see above") + else incr compte; + Wserver.wprint "."; + return + if levt.(Adef.int_of_iper x.cle_index) == niveau then + do levt.(Adef.int_of_iper x.cle_index) := infini; + if Array.length x.family <> 0 then + Wserver.wprint "
      " + else (); + Wserver.wprint "\n"; + if niveau == niveau_max then + let _ = + List.fold_left + (fun first ifam -> + let fam = foi base ifam in + let c = conjoint x (coi base ifam) in + let c = poi base c in + do if connais base c then + do afficher_marie conf base first fam x + c; + Wserver.wprint ".
      \n"; + return () + else (); + return False) + True (Array.to_list x.family) + in + () + else (); + return boucle (succ niveau) x + else Wserver.wprint "\n" +; + +value afficher_descendants_jusqu_a conf base niveau_max p = + let niveau_max = min limit_by_list niveau_max in + let levt = make_level_table base niveau_max p in + let compte = ref 0 in + let rec boucle niveau p = + if niveau <= niveau_max then + let _ = + List.fold_left + (fun first ifam -> + let fam = foi base ifam in + let cpl = coi base ifam in + let conj = conjoint p cpl in + let enfants = fam.children in + let conj = poi base conj in + do if connais base conj then + do afficher_marie conf base first fam p conj; + if Array.length enfants <> 0 then + Wserver.wprint ", %s" + (transl conf "having as children") + else Wserver.wprint "."; + Wserver.wprint "
      \n"; + return () + else (); + if Array.length enfants <> 0 then + tag "ul" begin + Array.iter + (print_child conf base levt boucle niveau_max niveau + compte) + enfants; + end + else (); + return False) + True (Array.to_list p.family) + in + () + else () + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text_no_html conf base p)) + else + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text conf base p)) + in + do header conf title; +(* + if niveau_max > 6 then enter_nobr () else (); +*) + Wserver.wprint "%s.

      \n" (capitale (text_to conf niveau_max)); + stag "strong" begin + afficher_personne_referencee conf base p; + end; + Date.afficher_dates conf base p; + Wserver.wprint ".
      \n"; + boucle 1 p; + Wserver.wprint "

      \n"; + Wserver.wprint "%s: %d %s" (capitale (transl conf "total")) compte.val + (transl_nth conf "person/persons" 1); + if niveau_max > 1 then + Wserver.wprint " (%s)" (transl conf "spouses not included") + else (); + Wserver.wprint ".\n"; +(* + if niveau_max > 6 then exit_nobr () else (); +*) + trailer conf; + return () +; + +value afficher_descendants_niveau conf base niveau_max ancetre = + let levt = make_level_table base niveau_max ancetre in + let rec get_level niveau p list = + List.fold_left + (fun list ifam -> + let fam = foi base ifam in + let enfants = fam.children in + List.fold_left + (fun list x -> + let x = poi base x in + if niveau == niveau_max then + if sou base x.first_name = "x" || + levt.(Adef.int_of_iper x.cle_index) != niveau then + list + else [x :: list] + else if niveau < niveau_max then get_level (succ niveau) x list + else list) + list (Array.to_list enfants)) + list (Array.to_list p.family) + in + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text_no_html conf base ancetre)) + else + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text conf base ancetre)) + in + let len = ref 0 in + let liste = get_level 1 ancetre [] in + let liste = + Sort.list + (fun p1 p2 -> + let c = alphabetique (sou base p1.surname) (sou base p2.surname) in + if c == 0 then + let c = + alphabetique (sou base p1.first_name) (sou base p2.first_name) + in + if c == 0 then p1.occ > p2.occ else c > 0 + else c > 0) + liste + in + let liste = + List.fold_left + (fun pl p -> + match pl with + [ [(p1, n) :: pl] when p.cle_index == p1.cle_index -> + [(p1, succ n) :: pl] + | _ -> do incr len; return [(p, 1) :: pl] ]) + [] liste + in + do header conf title; + Wserver.wprint "%s" (capitale (text_level conf niveau_max)); + if len.val > 1 then + Wserver.wprint " (%d %s)" len.val (transl_nth conf "person/persons" 1) + else (); + Wserver.wprint ".\n

      \n"; + print_alphab_list + (fun (p, _) -> + String.sub (sou base p.surname) (initiale (sou base p.surname)) 1) + (fun (p, c) -> + do afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + if c > 1 then Wserver.wprint " (%d)" c else (); + Wserver.wprint "\n"; + return ()) + liste; + trailer conf; + return () +; + +(* Avec numerotation *) + +value mark_descendants base marks max_lev = + loop 0 where rec loop lev p = + if lev <= max_lev then + do marks.(Adef.int_of_iper p.cle_index) := True; return + Array.iter + (fun ifam -> + let el = (foi base ifam).children in + Array.iter (fun e -> loop (succ lev) (poi base e)) el) + p.family + else () +; + +value label_descendants base marks paths max_lev = + loop [] 0 where rec loop path lev p = + if lev < max_lev then + let _ = + List.fold_left + (fun cnt ifam -> + let fam = foi base ifam in + let c = conjoint p (coi base ifam) in + let el = fam.children in + List.fold_left + (fun cnt e -> + do if p.sexe == Masculin || + not marks.(Adef.int_of_iper c) then + let path = [Char.chr (Char.code 'A' + cnt) :: path] in + do paths.(Adef.int_of_iper e) := path; + loop path (succ lev) (poi base e); + return () + else (); + return succ cnt) + cnt (Array.to_list el)) + 0 (Array.to_list p.family) + in + () + else () +; + +value close_lev = 2; + +value close_to_end base marks max_lev lev p = + if lev + close_lev >= max_lev then True + else + let rec short dlev p = + List.for_all + (fun ifam -> + let fam = foi base ifam in + let c = conjoint p (coi base ifam) in + let el = fam.children in + if p.sexe == Masculin || not marks.(Adef.int_of_iper c) then + if dlev == close_lev then Array.length el = 0 + else + List.for_all (fun e -> short (succ dlev) (poi base e)) + (Array.to_list el) + else True) + (Array.to_list p.family) + in + short 1 p +; + +value labelled base marks max_lev lev p = + let a = aoi base p.cle_index in + Array.length p.family <> 0 && + (match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + List.exists + (fun ifam -> + let el = (foi base ifam).children in + List.exists + (fun e -> + let e = poi base e in + Array.length e.family <> 0 && + not (close_to_end base marks max_lev lev e)) + (Array.to_list el)) + (Array.to_list (poi base cpl.father).family) + | _ -> False ]) +; + +value label_of_path paths p = + loop paths.(Adef.int_of_iper p.cle_index) where rec loop = + fun + [ [] -> "" + | [c :: cl] -> loop cl ^ String.make 1 c ] +; + +value print_child conf base p1 p2 e = + do stag "strong" begin + if p1.sexe == Masculin && e.surname == p1.surname || + p2.sexe == Masculin && e.surname == p2.surname then + afficher_prenom_de_personne_referencee conf base e + else afficher_personne_referencee conf base e; + end; + Date.afficher_dates_courtes conf base e; + return () +; + +value print_repeat_child conf base p1 p2 e = + stag "em" begin + if p1.sexe == Masculin && e.surname == p1.surname || + p2.sexe == Masculin && e.surname == p2.surname then + afficher_prenom_de_personne conf base e + else afficher_personne conf base e; + end +; + +value afficher_date_mariage conf base p c dmar = + if age_autorise conf base p && age_autorise conf base c then + match dmar with + [ Some d -> Wserver.wprint "%d" (annee d) + | None -> () ] + else () +; + +value afficher_conjoint conf base marks paths p c dmar = + do Wserver.wprint "&"; + afficher_date_mariage conf base p c dmar; + Wserver.wprint " "; + stag "strong" begin + afficher_personne_referencee conf base c; + end; + if marks.(Adef.int_of_iper c.cle_index) then + Wserver.wprint " (%s)" (label_of_path paths c) + else Date.afficher_dates_courtes conf base c; + return () +; + +value total = ref 0; + +value print_family_locally conf base marks paths max_lev lev p1 c1 e = + loop lev e where rec loop lev p = + if lev < max_lev then + let _ = + List.fold_left + (fun (cnt, first, need_br) ifam -> + let fam = foi base ifam in + let dmar = Adef.od_of_codate fam.marriage in + let c = conjoint p (coi base ifam) in + let el = fam.children in + let c = poi base c in + do if need_br then Wserver.wprint "
      " else (); + if not first then print_repeat_child conf base p1 c1 e + else (); + afficher_conjoint conf base marks paths p c dmar; + Wserver.wprint "\n"; + return + let print_children = + p.sexe == Masculin || + not marks.(Adef.int_of_iper c.cle_index) + in + do if print_children then + Wserver.wprint "

        \n" (succ cnt) + else (); + return + let cnt = + List.fold_left + (fun cnt e -> + let e = poi base e in + do if print_children then + do Wserver.wprint "
      1. "; + print_child conf base p c e; + Wserver.wprint "\n"; + incr total; + if succ lev == max_lev then + let _ = + List.fold_left + (fun first ifam -> + let fam = foi base ifam in + let dm = + Adef.od_of_codate fam.marriage + in + let c1 = conjoint e (coi base ifam) in + let el = fam.children in + let c1 = poi base c1 in + do if not first then + do Wserver.wprint "
        \n"; + print_repeat_child conf base p c + e; + return () + else (); + afficher_conjoint conf base marks + paths e c1 dm; + if Array.length el <> 0 then + Wserver.wprint "....." + else (); + Wserver.wprint "\n"; + return False) + True (Array.to_list e.family) + in + () + else loop (succ lev) e; + return () + else (); + return succ cnt) + cnt (Array.to_list el) + in + do if print_children then Wserver.wprint "
      \n" else (); return + (cnt, False, not print_children)) + (0, True, False) (Array.to_list p.family) + in + () + else () +; + +value last_label = ref ""; + +value print_family conf base marks paths max_lev lev p = + do if lev <> 0 then + Wserver.wprint "%s.
      \n" (label_of_path paths p) + else (); + do let lab = label_of_path paths p in + if lab < last_label.val then failwith "print_family" + else last_label.val := lab; + return (); + return + let _ = + List.fold_left + (fun cnt ifam -> + let fam = foi base ifam in + let dmar = Adef.od_of_codate fam.marriage in + let c = conjoint p (coi base ifam) in + let el = fam.children in + let c = poi base c in + do stag "strong" begin + afficher_personne_referencee conf base p; + end; + afficher_conjoint conf base marks paths p c dmar; + Wserver.wprint "
        \n" (succ cnt); + return + let cnt = + List.fold_left + (fun cnt e -> + let e = poi base e in + do if p.sexe == Masculin || + not marks.(Adef.int_of_iper c.cle_index) then + do Wserver.wprint "
      1. "; + print_child conf base p c e; + incr total; + Wserver.wprint "\n"; + if labelled base marks max_lev lev e then + Wserver.wprint " => %s\n" + (label_of_path paths e) + else if succ lev == max_lev then + Array.iter + (fun ifam -> + let fam = foi base ifam in + let dm = + Adef.od_of_codate fam.marriage + in + let c = conjoint e (coi base ifam) in + let el = fam.children in + let c = poi base c in + do afficher_conjoint conf base marks paths e c + dm; + if Array.length el <> 0 then + Wserver.wprint "....." + else (); + Wserver.wprint "\n"; + return ()) + e.family + else + print_family_locally conf base marks paths max_lev + (succ lev) p c e; + return () + else (); + return succ cnt) + cnt (Array.to_list el) + in + do Wserver.wprint "
      \n"; return cnt) + 0 (Array.to_list p.family) + in + () +; + +value print_families conf base marks paths max_lev = + loop 0 where rec loop lev p = + if lev < max_lev then + do print_family conf base marks paths max_lev lev p; return + Array.iter + (fun ifam -> + let fam = foi base ifam in + let c = conjoint p (coi base ifam) in + let el = fam.children in + let c = poi base c in + if p.sexe == Masculin || + not marks.(Adef.int_of_iper c.cle_index) then + Array.iter + (fun e -> + let e = poi base e in + if labelled base marks max_lev lev e then loop (succ lev) e + else ()) + el + else ()) + p.family + else () +; + +value afficher_descendants_numerotation conf base niveau_max ancetre = + let title h = + if h then + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text_no_html conf base ancetre)) + else + stag "a" "href=\"%sm=D;i=%d;v=%d;t=G\"" (commd conf) + (Adef.int_of_iper ancetre.cle_index) niveau_max + begin + Wserver.wprint "%s %s" (capitale (transl conf "descendants")) + (transl_concat conf "of" (person_text conf base ancetre)); + end + in + let marks = Array.create (base.persons.len) False in + let paths = Array.create (base.persons.len) [] in + do header conf title; + total.val := 0; + Date.afficher_dates_courtes conf base ancetre; + let p = ancetre in + if age_autorise conf base p then + match (Adef.od_of_codate p.birth, p.death) with + [ (Some _, _) | (_, Death _ _) -> Wserver.wprint "
      \n" + | _ -> () ] + else (); + Wserver.wprint "%s.

      \n" (capitale (text_to conf niveau_max)); + mark_descendants base marks niveau_max ancetre; + label_descendants base marks paths niveau_max ancetre; + print_families conf base marks paths niveau_max ancetre; + if total.val > 1 then + do Wserver.wprint "

      \n%s: %d %s" (capitale (transl conf "total")) + total.val (transl_nth conf "person/persons" 1); + if niveau_max > 1 then + Wserver.wprint " (%s)" (transl conf "spouses not included") + else (); + Wserver.wprint ".\n"; + return () + else (); + trailer conf; + return () +; + +value print_ref base paths p = + if paths.(Adef.int_of_iper p.cle_index) <> [] then + Wserver.wprint " => %s" (label_of_path paths p) + else + Array.iter + (fun ifam -> + let c = conjoint p (coi base ifam) in + if paths.(Adef.int_of_iper c) <> [] then + let c = poi base c in + Wserver.wprint " => %s %s %s" + (sou base c.first_name) (sou base c.surname) + (label_of_path paths c) + else ()) + p.family +; + +value print_elem conf base paths precision (n, pll) = + do Wserver.wprint "

    • "; + match pll with + [ [[p]] -> + do Wserver.wprint "%s " (surname_end n); + Wserver.wprint "" (commd conf) + (Adef.int_of_iper p.cle_index); + Wserver.wprint "%s" (sou base p.first_name); + Wserver.wprint "%s" (surname_begin n); + Date.afficher_dates_courtes conf base p; + print_ref base paths p; + Wserver.wprint "\n"; + return () + | _ -> + do Wserver.wprint "%s%s\n" (surname_end n) + (surname_begin n); + tag "ul" begin + List.iter + (fun pl -> + let several = + match pl with + [ [_] -> False + | _ -> True ] + in + List.iter + (fun p -> + do Wserver.wprint "
    • "; + stag "strong" begin + stag "a" "href=\"%si=%d\"" + (commd conf) + (Adef.int_of_iper p.cle_index) + begin + Wserver.wprint "%s" + (sou base p.first_name); + end; + end; + if several && precision then + do Wserver.wprint " "; + preciser_homonyme conf base p; + Wserver.wprint ""; + return () + else (); + Date.afficher_dates_courtes conf base p; + print_ref base paths p; + Wserver.wprint "\n"; + return ()) + pl) + pll; + end; + return () ]; + return () +; + +value trier_et_afficher conf base paths precision liste = + let liste = List.map (poi base) liste in + let liste = + Sort.list + (fun p1 p2 -> + let c = alphabetique (sou base p1.surname) (sou base p2.surname) in + if c == 0 then + let c = + alphabetique (sou base p1.first_name) (sou base p2.first_name) + in + c < 0 + else c > 0) + liste + in + let liste = + List.fold_left + (fun npll p -> + match npll with + [ [(n, pl) :: npll] when n == sou base p.surname -> + [(n, [p :: pl]) :: npll] + | _ -> [(sou base p.surname, [p]) :: npll] ]) + [] liste + in + let liste = + List.map + (fun (n, pl) -> + let pll = + List.fold_left + (fun pll p -> + match pll with + [ [([p1 :: _] as pl) :: pll] + when p1.first_name == p.first_name -> + [[p :: pl] :: pll] + | _ -> [[p] :: pll] ]) + [] pl + in + (n, pll)) + liste + in + if liste <> [] then + tag "ul" begin + List.iter (print_elem conf base paths precision) liste; + end + else () +; + +value afficher_index_descendants conf base niveau_max ancetre = + let title h = + do if not h then + Wserver.wprint "" (commd conf) + (Adef.int_of_iper ancetre.cle_index) niveau_max + else (); + Wserver.wprint "%s" (capitale (transl conf "index of the descendants")); + if not h then Wserver.wprint "" else (); + return () + in + do header conf title; return + let marks = Array.create (base.persons.len) False in + let paths = Array.create (base.persons.len) [] in + do mark_descendants base marks niveau_max ancetre; + label_descendants base marks paths niveau_max ancetre; + return + let liste = ref [] in + do for i = 0 to base.persons.len - 1 do + if paths.(i) <> [] then + let p = base.persons.get i in + if sou base p.first_name <> "?" && sou base p.surname <> "?" && + sou base p.first_name <> "x" then + liste.val := [p.cle_index :: liste.val] + else () + else (); + done; + trier_et_afficher conf base paths True liste.val; + trailer conf; + return () +; + +value afficher_index_conjoints conf base niveau_max ancetre = + let title _ = + Wserver.wprint "%s" + (capitale (transl conf "index of the spouses (non descendants)")) + in + do header conf title; return + let marks = Array.create (base.persons.len) False in + let paths = Array.create (base.persons.len) [] in + do mark_descendants base marks niveau_max ancetre; + label_descendants base marks paths niveau_max ancetre; + return + let liste = ref [] in + do for i = 0 to base.persons.len - 1 do + if paths.(i) <> [] then + let p = base.persons.get i in + if sou base p.first_name <> "?" && sou base p.surname <> "?" && + sou base p.first_name <> "x" then + Array.iter + (fun ifam -> + let c = conjoint p (coi base ifam) in + if paths.(Adef.int_of_iper c) = [] then + let c = poi base c in + if sou base c.first_name <> "?" && + sou base c.surname <> "?" && + sou base p.first_name <> "x" && + not (List.memq c.cle_index liste.val) then + liste.val := [c.cle_index :: liste.val] + else () + else ()) + p.family + else () + else (); + done; + trier_et_afficher conf base paths False liste.val; + trailer conf; + return () +; + +value print_someone conf base p = + do afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return () +; + +value children_of base ip = + List.fold_right + (fun ifam children -> Array.to_list (foi base ifam).children @ children) + (Array.to_list (poi base ip).family) [] +; + +value rec print_table_person conf base max_lev ip = + do Wserver.wprint "\n"; + tag "table" "border" begin + Wserver.wprint "\n"; + tag "td" "valign=top" begin + print_someone conf base (poi base ip); + end; + if max_lev > 0 then + match children_of base ip with + [ [] -> () + | ipl -> + do Wserver.wprint "\n"; + List.iter (print_table_person conf base (max_lev - 1)) ipl; + Wserver.wprint "\n"; + return () ] + else (); + end; + return () +; + +value afficher_descendants_table conf base max_lev a = + let title _ = Wserver.wprint "%s" (capitale (transl conf "descendants")) in + do header conf title; + print_table_person conf base max_lev a.cle_index; + trailer conf; + return () +; + +value print conf base p = + match (p_getenv conf.env "t", p_getint conf.env "v") with + [ (Some "L", Some v) -> afficher_descendants_jusqu_a conf base v p + | (Some "S", Some v) -> afficher_descendants_niveau conf base v p + | (Some "T", Some v) -> afficher_descendants_table conf base v p + | (Some "N", Some v) -> afficher_descendants_numerotation conf base v p + | (Some "G", Some v) -> afficher_index_descendants conf base v p + | (Some "C", Some v) -> afficher_index_conjoints conf base v p + | _ -> afficher_menu_descendants conf base p ] +; diff --git a/src/family.ml b/src/family.ml new file mode 100644 index 0000000000..9bb7f0bf38 --- /dev/null +++ b/src/family.ml @@ -0,0 +1,317 @@ +(* camlp4r ./def.syn.cmo *) +(* $Id: family.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +open Def; +open Gutil; +open Config; +open Util; + +value person_is_std_key base p k = + let k = Name.strip_lower k in + if k = Name.strip_lower (sou base p.first_name ^ " " ^ sou base p.surname) + then True + else if + List.exists (fun n -> Name.strip n = k) (person_misc_names base p) + then True + else False +; + +value select_std_eq base pl k = + List.fold_right + (fun p pl -> if person_is_std_key base p k then [p :: pl] else pl) + pl [] +; + +value inconnu_au_bataillon conf = + match (p_getenv conf.env "n", p_getenv conf.env "p") with + [ (Some nom, Some prenom) -> + let title _ = + Wserver.wprint "%s: \"%s %s\"" (capitale (transl conf "not found")) + prenom nom + in + do header conf title; trailer conf; return () + | _ -> incorrect_request conf ] +; + +value inconnu conf n = + let title _ = + Wserver.wprint "%s: \"%s\"" (capitale (transl conf "not found")) n + in + do header conf title; trailer conf; return () +; + +value person_selected conf base senv p = + match p_getenv senv "m" with + [ Some "R" -> Relation.print conf senv base p + | Some mode -> incorrect_request conf + | None -> Perso.print conf base p ] +; + +value compact_list conf base xl = + let pl = + Sort.list + (fun p1 p2 -> + match + (Adef.od_of_codate p1.birth, p1.death, + Adef.od_of_codate p2.birth, p2.death) + with + [ (Some d1, _, Some d2, _) -> d1 strictement_avant d2 + | (Some d1, _, _, Death _ d2) -> + d1 strictement_avant Adef.date_of_cdate d2 + | (_, Death _ d1, Some d2, _) -> + Adef.date_of_cdate d1 strictement_avant d2 + | (_, Death _ d1, _, Death _ d2) -> + Adef.date_of_cdate d1 strictement_avant Adef.date_of_cdate d2 + | (Some _, _, _, _) -> True + | (_, Death _ _, _, _) -> True + | _ -> + let c = + alphabetique (sou base p1.surname) (sou base p2.surname) + in + if c == 0 then + let c = + alphabetique (sou base p1.first_name) (sou base p2.first_name) + in + if c == 0 then p1.occ > p2.occ else c > 0 + else c > 0 ]) + (List.map (poi base) xl) + in + let pl = + List.fold_right + (fun p pl -> + match pl with + [ [p1 :: _] when p == p1 -> pl + | _ -> [p :: pl] ]) + pl [] + in + pl +; + +value precisez conf base n pl = + let title _ = Wserver.wprint "%s : %s" n (transl conf "specify") in + let n = Name.crush_lower n in + let ptll = + List.map + (fun p -> + let tl = ref [] in + let add_tl t = + tl.val := + let rec add_rec = + fun + [ [t1 :: tl1] -> + if t1.t_title = t.t_title && t1.t_place = t.t_place then + [t1 :: tl1] + else [t1 :: add_rec tl1] + | [] -> [t] ] + in + add_rec tl.val + in + let compare_and_add t pn = + let pn = sou base pn in + if Name.crush_lower pn = n then add_tl t + else + match p.nick_names with + [ [nn :: _] -> + let nn = sou base nn in + if Name.crush_lower (pn ^ " " ^ nn) = n then add_tl t + else () + | _ -> () ] + in + do List.iter + (fun t -> + match (t.t_name, p.public_name) with + [ (Tname s, _) -> compare_and_add t s + | (_, pn) when sou base pn <> "" -> compare_and_add t pn + | _ -> () ]) + p.titles; + return (p, tl.val)) + pl + in + do header conf title; + Wserver.wprint "
        \n"; + List.iter + (fun (p, tl) -> + do Wserver.wprint "
      • \n"; + match tl with + [ [] -> afficher_personne_titre_referencee conf base p + | [t :: tl] -> + do afficher_personne_un_titre_referencee conf base p t; + List.iter (afficher_un_titre conf base p) tl; + return () ]; + Date.afficher_dates_courtes conf base p; + match p.sexe with + [ Feminin -> + let husbands = + List.fold_right + (fun ifam husbands -> + let cpl = coi base ifam in + let husband = poi base cpl.father in + if sou base husband.surname <> "?" then + [husband :: husbands] + else husbands) + (Array.to_list p.family) [] + in + match husbands with + [ [] -> () + | [h :: hl] -> + do Wserver.wprint ", %s " + (transl_nth conf "spouse" 1); + afficher_personne_titre conf base h; + List.iter + (fun h -> + do Wserver.wprint ", %s\n" (transl conf "and"); + afficher_personne_titre conf base h; + return ()) + hl; + Wserver.wprint "\n"; + return () ] + | _ -> () ]; + return ()) + ptll; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value family_m conf base = + do conf.senv := + match try Some (List.assoc "e" conf.env) with _ -> None with + [ Some s -> s + | _ -> "" ]; + return + let senv = Util.create_env (decode_varenv conf.senv) in + match p_getenv conf.env "m" with + [ Some "A" -> + match find_person_in_env conf base "" with + [ Some p -> Ascend.print conf base p + | _ -> inconnu_au_bataillon conf ] + | Some "ADD_FAM" when conf.wizard -> + UpdateFam.print_add conf base + | Some "ADD_FAM_OK" when conf.wizard -> + UpdateFamOk.print_add conf base + | Some "ADD_IND" when conf.wizard -> + UpdateInd.print_add conf base + | Some "ADD_IND_OK" when conf.wizard -> + UpdateIndOk.print_add conf base + | Some "ADD_PAR" when conf.wizard -> + UpdateFam.print_add_parents conf base + | Some "AN" -> + match p_getenv conf.env "v" with + [ Some x -> Birthday.print conf base (int_of_string x) + | _ -> Birthday.menu_print conf base ] + | Some "AD" -> + match p_getenv conf.env "v" with + [ Some x -> Birthday.print_dead conf base (int_of_string x) + | _ -> Birthday.menu_print_dead conf base ] + | Some "AM" -> + match p_getenv conf.env "v" with + [ Some x -> Birthday.print_marriage conf base (int_of_string x) + | _ -> Birthday.print_menu_marriage conf base ] + | Some "AS_OK" -> + AdvSearchOk.print conf base + | Some "B" when conf.wizard || conf.friend -> Birth.print conf base + | Some "D" -> + match find_person_in_env conf base "" with + [ Some p -> Descend.print conf base p + | _ -> inconnu_au_bataillon conf ] + | Some "DEL_FAM" when conf.wizard -> + UpdateFam.print_del conf base + | Some "DEL_FAM_OK" when conf.wizard -> + UpdateFamOk.print_del conf base + | Some "DEL_IND" when conf.wizard -> + UpdateInd.print_del conf base + | Some "DEL_IND_OK" when conf.wizard -> + UpdateIndOk.print_del conf base + | Some "H" -> + match p_getenv conf.env "v" with + [ Some f -> Srcfile.print conf base f + | None -> () ] + | Some "LEX" -> Srcfile.print_lexicon conf base + | Some "MRG" when conf.wizard -> + match find_person_in_env conf base "" with + [ Some p -> Merge.print conf base p + | _ -> inconnu_au_bataillon conf ] + | Some "MRG_FAM" when conf.wizard -> + MergeFam.print conf base + | Some "MRG_FAM_OK" when conf.wizard -> + MergeFamOk.print_merge conf base + | Some "MRG_MOD_FAM_OK" when conf.wizard -> + MergeFamOk.print_mod_merge conf base + | Some "MRG_IND" when conf.wizard -> + MergeInd.print conf base + | Some "MRG_IND_OK" when conf.wizard -> + MergeIndOk.print_merge conf base + | Some "MRG_MOD_IND_OK" when conf.wizard -> + MergeIndOk.print_mod_merge conf base + | Some "MOD_FAM" when conf.wizard -> + UpdateFam.print_mod conf base + | Some "MOD_FAM_OK" when conf.wizard -> + UpdateFamOk.print_mod conf base + | Some "MOD_IND" when conf.wizard -> + UpdateInd.print_mod conf base + | Some "MOD_IND_OK" when conf.wizard -> + UpdateIndOk.print_mod conf base + | Some "N" -> + match p_getenv conf.env "v" with + [ Some v -> Some.surname_print conf base v + | _ -> Alln.family_names_print conf base ] + | Some "NG" -> + match p_getenv conf.env "n" with + [ Some n -> + match p_getenv conf.env "t" with + [ Some "P" -> Some.first_name_print conf base n + | Some "N" -> Some.surname_print conf base n + | _ -> + let pl = person_ht_find_all base n in + let pl = compact_list conf base pl in + let pl = + let spl = select_std_eq base pl n in + if spl = [] then pl else spl + in + match pl with + [ [] -> inconnu conf n + | [p] -> person_selected conf base senv p + | pl -> precisez conf base n pl ] ] + | None -> () ] + | Some "P" -> + match p_getenv conf.env "v" with + [ Some v -> Some.first_name_print conf base v + | None -> Alln.first_names_print conf base ] + | Some "R" -> + match find_person_in_env conf base "" with + [ Some p -> Relation.print conf senv base p + | _ -> inconnu_au_bataillon conf ] + | Some "REQUEST" when conf.wizard -> + let title _ = () in + do header conf title; + Wserver.wprint "
      \n";
+         List.iter (Wserver.wprint "%s\n") conf.request;
+         Wserver.wprint "
      \n"; + trailer conf; + return () + | Some "RL" -> RelationLink.print conf base + | Some "SWI_FAM" when conf.wizard -> + UpdateFam.print_swi conf base + | Some "SWI_FAM_OK" when conf.wizard -> + UpdateFamOk.print_swi conf base + | Some "TT" -> Title.print conf base + | Some "U" when conf.wizard -> + match find_person_in_env conf base "" with + [ Some p -> Update.print conf base p + | _ -> inconnu_au_bataillon conf ] + | Some mode -> incorrect_request conf + | None -> + match find_person_in_env conf base "" with + [ Some p -> person_selected conf base senv p + | _ -> inconnu_au_bataillon conf ] ] +; + +value family conf base = + do if conf.env = [] then + do Srcfile.incr_welcome_counter conf; return + Srcfile.print_start conf base + else + do Srcfile.incr_request_counter conf; return + family_m conf base; + return Wserver.wflush () +; diff --git a/src/family.mli b/src/family.mli new file mode 100644 index 0000000000..e8f0a70d97 --- /dev/null +++ b/src/family.mli @@ -0,0 +1,3 @@ +(* $Id: family.mli,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +value family : Config.config -> Def.base -> unit; diff --git a/src/gutil.ml b/src/gutil.ml new file mode 100644 index 0000000000..1541a50b3b --- /dev/null +++ b/src/gutil.ml @@ -0,0 +1,714 @@ +(* $Id: gutil.ml,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +open Def; + +value poi base i = base.persons.get (Adef.int_of_iper i); +value aoi base i = base.ascends.get (Adef.int_of_iper i); +value foi base i = base.families.get (Adef.int_of_ifam i); +value coi base i = base.couples.get (Adef.int_of_ifam i); +value sou base i = base.strings.get (Adef.int_of_istr i); + +value bissextile a = + if a mod 100 == 0 then a / 100 mod 4 == 0 else a mod 4 == 0 +; + +value nb_jours_dans_mois = + let tb = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] in + fun m a -> if m == 2 && bissextile a then 29 else tb.(m - 1) +; + +value temps_ecoule d1 d2 = + match d1 with + [ Djma j1 m1 a1 -> + match d2 with + [ Djma j2 m2 a2 -> + let (jour, r) = + if j1 <= j2 then (j2 - j1, 0) + else (j2 - j1 + nb_jours_dans_mois m1 a1, 1) + in + let (mois, r) = + if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1) + in + let annee = a2 - a1 - r in Djma jour mois annee + | Dma m2 a2 -> + let r = 0 in + let (mois, r) = + if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1) + in + let annee = a2 - a1 - r in Dma mois annee + | Da sure a2 -> Da sure (a2 - a1) ] + | Dma m1 a1 -> + match d2 with + [ Djma j2 m2 a2 -> + let r = 0 in + let (mois, r) = + if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1) + in + let annee = a2 - a1 - r in Dma mois annee + | Dma m2 a2 -> + let r = 0 in + let (mois, r) = + if m1 + r <= m2 then (m2 - m1 - r, 0) else (m2 - m1 - r + 12, 1) + in + let annee = a2 - a1 - r in Dma mois annee + | Da sure a2 -> Da sure (a2 - a1) ] + | Da sure a1 -> + match d2 with + [ Djma _ _ a2 -> Da sure (a2 - a1) + | Dma _ a2 -> Da sure (a2 - a1) + | Da sure2 a2 -> + Da (match sure with + [ Sure -> sure2 + | About -> if sure2 = Sure then About else sure2 + | _ -> Maybe ]) + (a2 - a1) ] ] +; + +value annee = + fun + [ Djma _ _ a -> a + | Dma _ a -> a + | Da _ a -> a ] +; + +value strictement_avant d1 d2 = + match temps_ecoule d2 d1 with + [ Djma j m a -> a < 0 + | Dma m a -> a < 0 + | Da Sure a -> a < 0 + | Da _ a -> + if a < 0 then True + else if a > 0 then False + else + match (d1, d2) with + [ (Da p1 _, Da p2 _) when p1 = p2 -> False + | (Da Before _, _) | (_, Da After _) -> True + | _ -> False ] ] +; + +value strictement_apres d1 d2 = + match temps_ecoule d1 d2 with + [ Djma j m a -> a < 0 + | Dma m a -> a < 0 + | Da _ a -> + if a < 0 then True + else if a > 0 then False + else + match (d2, d1) with + [ (Da p2 _, Da p1 _) when p1 = p2 -> False + | (Da Before _, _) | (_, Da After _) -> True + | _ -> False ] ] +; + +value string_of_date = + fun + [ Djma j m a -> + "on " ^ string_of_int j ^ "/" ^ string_of_int m ^ "/" ^ string_of_int a + | Dma m a -> "in " ^ string_of_int m ^ "/" ^ string_of_int a + | Da Sure a -> "in " ^ string_of_int a + | Da About a -> "about " ^ string_of_int a + | Da Maybe a -> "maybe in " ^ string_of_int a + | Da Before a -> "before " ^ string_of_int a + | Da After a -> "after " ^ string_of_int a + | Da (OrYear a1) a -> "in " ^ string_of_int a ^ " or " ^ string_of_int a1 ] +; + +value denomination base p = + let prenom = sou base p.first_name in + let nom = sou base p.surname in + prenom ^ + (if p.occ == 0 || prenom = "?" || nom = "?" then "" + else "." ^ string_of_int p.occ) ^ + " " ^ nom +; + +value person_misc_names base p = + if sou base p.first_name = "?" || sou base p.surname = "?" then [] else + let public_names = + let titles_names = + let tnl = ref [] in + do List.iter + (fun t -> + match t.t_name with + [ Tmain | Tnone -> () + | Tname x -> tnl.val := [x :: tnl.val ] ]) + p.titles; + return tnl.val + in + if sou base p.public_name = "" then titles_names + else [p.public_name :: titles_names] + in + let first_names = [p.first_name :: p.first_names_aliases @ public_names] in + let surnames = [p.surname :: p.surnames_aliases @ p.nick_names] in + let surnames = + if p.sexe == Feminin then + List.fold_left + (fun list ifam -> + let cpl = coi base ifam in + let husband = poi base cpl.father in + if sou base husband.surname = "?" then + husband.surnames_aliases @ list + else [husband.surname :: husband.surnames_aliases @ list]) + surnames (Array.to_list p.family) + else surnames + in + let list = [] in + let list = + List.fold_left (fun list s -> [sou base s :: list]) list public_names + in + let list = + List.fold_left + (fun list f -> + let f = sou base f in + List.fold_left (fun list s -> [f ^ " " ^ sou base s :: list]) list + surnames) + list first_names + in + let list = + let first_names = + List.map (sou base) [p.first_name :: p.first_names_aliases] + in + List.fold_left + (fun list t -> + let s = sou base t.t_place in + if s = "" then list + else + let first_names = + match t.t_name with + [ Tname f -> [sou base f :: first_names] + | _ -> + let f = sou base p.public_name in + if f = "" then first_names + else [f :: first_names] ] + in + List.fold_left (fun list f -> [f ^ " " ^ s :: list]) list + first_names) + list p.titles + in + let list = + match (aoi base p.cle_index).parents with + [ Some ifam -> + let cpl = coi base ifam in + let fath = poi base cpl.father in + let first_names = + List.map (sou base) [p.first_name :: p.first_names_aliases] + in + List.fold_left + (fun list t -> + let s = sou base t.t_place in + if s = "" then list + else + List.fold_left (fun list f -> [f ^ " " ^ s :: list]) list + first_names) + list fath.titles + | _ -> list ] + in + let list = + List.fold_left (fun list s -> [sou base s :: list]) list p.aliases + in + let fn = Name.lower (sou base p.first_name ^ " " ^ sou base p.surname) in + List.fold_left + (fun list s -> + let s = Name.lower s in + if s = fn || List.mem s list then list else [s :: list]) + [] list +; + +value person_ht_add base s ip = base.patch_name s ip; + +value person_is_key base p k = + let k = Name.crush_lower k in + if k = Name.crush_lower (sou base p.first_name ^ " " ^ sou base p.surname) + then True + else if + List.exists (fun x -> k = Name.crush_lower x) (person_misc_names base p) + then True + else False +; + +value person_ht_find_unique base first_name surname occ = + if first_name = "?" || surname = "?" then raise Not_found + else + let ipl = base.persons_of_name (first_name ^ " " ^ surname) in + let first_name = Name.strip_lower first_name in + let surname = Name.strip_lower surname in + find ipl where rec find = + fun + [ [ip :: ipl] -> + let p = poi base ip in + if occ == p.occ + && first_name = Name.strip_lower (sou base p.first_name) + && surname = Name.strip_lower (sou base p.surname) + then p.cle_index + else find ipl + | _ -> raise Not_found ] +; + +value lindex s c = + pos 0 where rec pos i = + if i == String.length s then None + else if s.[i] == c then Some i else pos (i + 1) +; + +value find_num s i = + loop i i where rec loop start i = + if i == String.length s then None + else + match s.[i] with + [ '0'..'9' -> loop start (i + 1) + | c -> + if i == start then + if c = ' ' then loop (start + 1) (start + 1) else None + else Some (int_of_string (String.sub s start (i - start)), i) ] +; + +value get_unique base s = + match lindex s '.' with + [ Some i -> + match find_num s (i + 1) with + [ Some (occ, j) -> + let first_name = String.sub s 0 i in + let surname = String.sub s j (String.length s - j) in + try Some (person_ht_find_unique base first_name surname occ) with + [ Not_found -> None ] + | None -> None ] + | None -> None ] +; + +value person_ht_find_all base s = + match get_unique base s with + [ Some p -> [p] + | _ -> + let ipl = base.persons_of_name s in + select ipl where rec select = + fun + [ [ip :: ipl] -> + if person_is_key base (poi base ip) s then [ip :: select ipl] + else select ipl + | [] -> [] ] ] +; + +(* check base *) + +type error 'person = + [ AlreadyDefined of 'person + | OwnAncestor of 'person + | BadSexOfMarriedPerson of 'person ] +; +type base_error = error base_person; + +type warning 'person = + [ BirthAfterDeath of 'person + | ChangedOrderOfChildren of base_family and array iper + | ChildrenNotInOrder of base_family and 'person and 'person + | DeadTooEarlyToBeFather of 'person and 'person + | MarriageDateAfterDeath of 'person + | MarriageDateBeforeBirth of 'person + | MotherDeadAfterChildBirth of 'person and 'person + | ParentBornAfterChild of 'person and 'person + | ParentTooYoung of 'person and Def.date + | TitleDatesError of 'person and title istr + | YoungForMarriage of 'person and Def.date ] +; +type base_warning = warning base_person; + +type visit = [ NotVisited | BeingVisited | Visited ]; + +value check_noloop base error = + let tab = Array.create (base.persons.len) NotVisited in + let rec noloop i = + match tab.(i) with + [ NotVisited -> + do match (base.ascends.get i).parents with + [ Some fam -> + let fath = (coi base fam).father in + let moth = (coi base fam).mother in + do tab.(i) := BeingVisited; + noloop (Adef.int_of_iper fath); + noloop (Adef.int_of_iper moth); + return () + | None -> () ]; + tab.(i) := Visited; + return () + | BeingVisited -> error (OwnAncestor (base.persons.get i)) + | Visited -> () ] + in + for i = 0 to base.persons.len - 1 do + match tab.(i) with + [ NotVisited -> noloop i + | BeingVisited -> failwith "check_noloop algorithm error" + | Visited -> () ]; + done +; + +value check_noloop_for_person_list base error pl = + let tab = Array.create (base.persons.len) NotVisited in + let rec noloop p = + let i = Adef.int_of_iper p.cle_index in + match tab.(i) with + [ NotVisited -> + do match (aoi base p.cle_index).parents with + [ Some ifam -> + let cpl = coi base ifam in + do tab.(i) := BeingVisited; + noloop (poi base cpl.father); + noloop (poi base cpl.mother); + return () + | None -> () ]; + tab.(i) := Visited; + return () + | BeingVisited -> error (OwnAncestor p) + | Visited -> () ] + in + List.iter noloop pl +; + +value child_born_after_his_parent base error warning x iparent = + let parent = poi base iparent in + match + (Adef.od_of_codate parent.birth, Adef.od_of_codate x.birth, x.death) + with + [ (Some d1, Some d2, _) -> + if strictement_apres d1 d2 then + warning (ParentBornAfterChild parent x) + else + let a = temps_ecoule d1 d2 in + if annee a < 12 then warning (ParentTooYoung parent a) else () + | (Some d1, _, Death _ d2) -> + let d2 = Adef.date_of_cdate d2 in + if strictement_apres d1 d2 then + warning (ParentBornAfterChild parent x) + else + let a = temps_ecoule d1 d2 in + if annee a < 12 then warning (ParentTooYoung parent a) else () + | _ -> () ] +; + +value born_after_his_elder_sibling base error warning x np fam = + match (np, Adef.od_of_codate x.birth, x.death) with + [ (None, _, _) -> () + | (Some (elder, d1), Some d2, _) -> + if strictement_apres d1 d2 then warning (ChildrenNotInOrder fam elder x) + else () + | (Some (elder, d1), _, Death _ d2) -> + let d2 = Adef.date_of_cdate d2 in + if strictement_apres d1 d2 then warning (ChildrenNotInOrder fam elder x) + else () + | _ -> () ] +; + +value child_born_before_mother_death base warning x imoth = + let mother = poi base imoth in + match (Adef.od_of_codate x.birth, mother.death) with + [ (Some d1, Death _ d2) -> + let d2 = Adef.date_of_cdate d2 in + if strictement_apres d1 d2 then + warning (MotherDeadAfterChildBirth mother x) + else () + | _ -> () ] +; + +value possible_father base warning x ifath = + let father = poi base ifath in + match (Adef.od_of_codate x.birth, father.death) with + [ (Some d1, Death _ d2) -> + match (d1, Adef.date_of_cdate d2) with + [ (Da Before _, _) | (_, Da After _) -> () + | (d1, d2) -> + if annee d1 > annee d2 + 1 then + warning (DeadTooEarlyToBeFather father x) + else () ] + | _ -> () ] +; + +value birth_before_death base warning p = + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d1, Death _ d2) -> + let d2 = Adef.date_of_cdate d2 in + if strictement_apres d1 d2 then warning (BirthAfterDeath p) + else () + | _ -> () ] +; + +value titles_while_living base warning p t = + let t_date_start = Adef.od_of_codate t.t_date_start in + let t_date_end = Adef.od_of_codate t.t_date_end in + do match (t_date_start, t_date_end) with + [ (Some d1, Some d2) -> + if strictement_apres d1 d2 then warning (TitleDatesError p t) + else () + | _ -> () ]; + match Adef.od_of_codate p.birth with + [ Some d1 -> + do match t_date_start with + [ Some d -> + if strictement_apres d1 d then + warning (TitleDatesError p t) + else () + | None -> () ]; + match t_date_end with + [ Some d -> + if strictement_apres d1 d then + warning (TitleDatesError p t) + else () + | None -> () ]; + return () + | _ -> () ]; + match p.death with + [ Death _ d1 -> + let d1 = Adef.date_of_cdate d1 in + do match t_date_start with + [ Some d -> + if strictement_apres d d1 then + warning (TitleDatesError p t) + else () + | None -> () ]; + match t_date_end with + [ Some d -> + if strictement_apres d d1 then + warning (TitleDatesError p t) + else () + | None -> () ]; + return () + | _ -> () ]; + return () +; + +value check_normal_marriage_date_for_someone base error warning fam ip = + let p = poi base ip in + match Adef.od_of_codate fam.marriage with + [ Some d2 -> + do match Adef.od_of_codate p.birth with + [ Some d1 -> + if strictement_avant d2 d1 then + warning (MarriageDateBeforeBirth p) + else if + annee d2 > 1850 && annee (temps_ecoule d1 d2) < 13 then + warning (YoungForMarriage p (temps_ecoule d1 d2)) + else () + | _ -> () ]; + match p.death with + [ Death _ d3 -> + let d3 = Adef.date_of_cdate d3 in + if strictement_apres d2 d3 then + warning (MarriageDateAfterDeath p) + else () + | _ -> () ]; + return () + | None -> () ] +; + +value check_normal_marriage_date base error warning fam = + let cpl = coi base fam.fam_index in + do check_normal_marriage_date_for_someone base error warning fam cpl.father; + check_normal_marriage_date_for_someone base error warning fam cpl.mother; + return () +; + +value sort_children base warning fam = + let before = ref None in + let a = fam.children in + do for i = 1 to Array.length a - 1 do + loop (i-1) where rec loop j = + if j >= 0 then + let p1 = poi base a.(j) in + let p2 = poi base a.(j+1) in + match (Adef.od_of_codate p1.birth, Adef.od_of_codate p2.birth) with + [ (Some d1, Some d2) -> + if strictement_avant d2 d1 then + let ip = a.(j+1) in + do match before.val with + [ Some _ -> () + | None -> before.val := Some (Array.copy a) ]; + a.(j+1) := a.(j); + a.(j) := ip; + return loop (j-1) + else () + | _ -> () ] + else (); + done; + match before.val with + [ None -> () + | Some a -> warning (ChangedOrderOfChildren fam a) ]; + return () +; + +value check_family base error warning fam = + let cpl = coi base fam.fam_index in + do match (poi base cpl.father).sexe with + [ Masculin -> () + | _ -> error (BadSexOfMarriedPerson (poi base cpl.father)) ]; + match (poi base cpl.mother).sexe with + [ Feminin -> () + | _ -> error (BadSexOfMarriedPerson (poi base cpl.mother)) ]; + check_normal_marriage_date base error warning fam; + sort_children base warning fam; + let _ = + List.fold_left + (fun np child -> + let child = poi base child in + do born_after_his_elder_sibling base error warning child np fam; + child_born_after_his_parent base error warning child cpl.father; + child_born_after_his_parent base error warning child cpl.mother; + child_born_before_mother_death base warning child cpl.mother; + possible_father base warning child cpl.father; + return + match Adef.od_of_codate child.birth with + [ Some d -> Some (child, d) + | _ -> np ]) + None (Array.to_list fam.children) + in + (); + return () +; + +value check_person base error warning p = + do birth_before_death base warning p; + List.iter (titles_while_living base warning p) p.titles; + return () +; + +value is_deleted_family fam = fam.fam_index = Adef.ifam_of_int (-1); + +value check_base base error warning = + do for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + check_person base error warning p; + done; + for i = 0 to base.families.len - 1 do + let fam = base.families.get i in + if is_deleted_family fam then () + else check_family base error warning fam; + done; + check_noloop base error; + return () +; + +value strip_controls_m s = + let len = + loop 0 0 where rec loop i len = + if i == String.length s then len + else if s.[i] == '\r' then loop (i + 1) len + else loop (i + 1) (len + 1) + in + if len == String.length s then s + else + let s' = String.create len in + loop 0 0 where rec loop i j = + if j == len then s' + else if s.[i] == '\r' then loop (i + 1) j + else do s'.[j] := s.[i]; return loop (i + 1) (j + 1) + +; + +value strip_spaces str = + let start = loop 0 + where rec loop i = + if i == String.length str then i + else + match str.[i] with + [ ' ' | '\r' | '\n' | '\t' -> loop (i + 1) + | _ -> i ] + in + let stop = loop (String.length str - 1) + where rec loop i = + if i == -1 then i + 1 + else + match str.[i] with + [ ' ' | '\r' | '\n' | '\t' -> loop (i - 1) + | _ -> i + 1 ] + in + if start == 0 && stop == String.length str then str + else if start > stop then "" + else String.sub str start (stop - start) +; + +value initiale n = + boucle 0 where rec boucle i = + if i == String.length n then 0 + else + match n.[i] with + [ 'A'..'Z' | 'À'..'Ý' -> i + | _ -> boucle (succ i) ] +; + +value valeur_alphabetique = + let tab = Array.create 256 0 in + do for i = 0 to 255 do tab.(i) := 10 * i; done; + tab.(Char.code 'à') := tab.(Char.code 'a') + 1; + tab.(Char.code 'á') := tab.(Char.code 'a') + 2; + tab.(Char.code 'â') := tab.(Char.code 'a') + 3; + tab.(Char.code 'è') := tab.(Char.code 'e') + 1; + tab.(Char.code 'é') := tab.(Char.code 'e') + 2; + tab.(Char.code 'ê') := tab.(Char.code 'e') + 3; + tab.(Char.code 'ë') := tab.(Char.code 'e') + 4; + tab.(Char.code 'ô') := tab.(Char.code 'o') + 1; + tab.(Char.code 'Á') := tab.(Char.code 'A') + 2; + tab.(Char.code 'Æ') := tab.(Char.code 'A') + 5; + tab.(Char.code 'È') := tab.(Char.code 'E') + 1; + tab.(Char.code 'É') := tab.(Char.code 'E') + 2; + tab.(Char.code 'Ö') := tab.(Char.code 'O') + 4; + tab.(Char.code '?') := 3000; + return fun x -> tab.(Char.code x) +; + +value alphabetique n1 n2 = + let rec boucle i1 i2 = + if i1 == String.length n1 && i2 == String.length n2 then i1 - i2 + else if i1 == String.length n1 then -1 + else if i2 == String.length n2 then 1 + else + let c1 = n1.[i1] in + let c2 = n2.[i2] in + if valeur_alphabetique c1 < valeur_alphabetique c2 then -1 + else if valeur_alphabetique c1 > valeur_alphabetique c2 then 1 + else boucle (succ i1) (succ i2) + in + if n1 = n2 then 0 else boucle (initiale n1) (initiale n2) +; + +value map_title_strings f t = + let t_name = + match t.t_name with + [ Tmain -> Tmain + | Tname s -> Tname (f s) + | Tnone -> Tnone ] + in + let t_title = f t.t_title in + let t_place = f t.t_place in + {t_name = t_name; t_title = t_title; t_place = t_place; + t_date_start = t.t_date_start; t_date_end = t.t_date_end; + t_nth = t.t_nth} +; + +value map_person_strings f p = + {first_name = f p.first_name; surname = f p.surname; occ = p.occ; + photo = f p.photo; first_names_aliases = List.map f p.first_names_aliases; + surnames_aliases = List.map f p.surnames_aliases; + public_name = f p.public_name; + nick_names = List.map f p.nick_names; + titles = List.map (map_title_strings f) p.titles; + aliases = List.map f p.aliases; + occupation = f p.occupation; + sexe = p.sexe; access = p.access; + birth = p.birth; birth_place = f p.birth_place; + baptism = p.baptism; baptism_place = f p.baptism_place; + death = p.death; death_place = f p.death_place; + burial = p.burial; burial_place = f p.burial_place; + family = p.family; notes = f p.notes; psources = f p.psources; + cle_index = p.cle_index} +; + +value map_family_ps fp fs fam = + {marriage = fam.marriage; marriage_place = fs fam.marriage_place; + divorce = fam.divorce; + children = Array.map fp fam.children; + comment = fs fam.comment; + origin_file = fs fam.origin_file; + fsources = fs fam.fsources; + fam_index = fam.fam_index} +; + +value map_couple_p fp fam = + {father = fp fam.father; mother = fp fam.mother} +; diff --git a/src/gutil.mli b/src/gutil.mli new file mode 100644 index 0000000000..0a65fec051 --- /dev/null +++ b/src/gutil.mli @@ -0,0 +1,80 @@ +(* $Id: gutil.mli,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +open Def; + +value poi : base -> iper -> base_person; +value aoi : base -> iper -> base_ascend; +value foi : base -> ifam -> base_family; +value coi : base -> ifam -> base_couple; +value sou : base -> istr -> string; + +value is_deleted_family : base_family -> bool; + +value person_ht_add : base -> string -> iper -> unit; +value person_ht_find_all : base -> string -> list iper; +value person_ht_find_unique : base -> string -> string -> int -> iper; +value person_misc_names : base -> base_person -> list string; + +value nb_jours_dans_mois : int -> int -> int; +value temps_ecoule : date -> date -> date; +value annee : date -> int; +value strictement_avant : date -> date -> bool; +value strictement_apres : date -> date -> bool; +value string_of_date : date -> string; + +value denomination : base -> base_person -> string; + +value map_title_strings : ('a -> 'b) -> Def.title 'a -> Def.title 'b; + +value map_person_strings : ('a -> 'b) -> Def.person 'a -> Def.person 'b; +value map_family_ps : + ('a -> 'c) -> ('b -> 'd) -> Def.family 'a 'b -> Def.family 'c 'd +; +value map_couple_p : ('a -> 'b) -> Def.couple 'a -> Def.couple 'b; + +(* check base *) + +type error 'person = + [ AlreadyDefined of 'person + | OwnAncestor of 'person + | BadSexOfMarriedPerson of 'person ] +; +type base_error = error base_person; + +type warning 'person = + [ BirthAfterDeath of 'person + | ChangedOrderOfChildren of base_family and array iper + | ChildrenNotInOrder of base_family and 'person and 'person + | DeadTooEarlyToBeFather of 'person and 'person + | MarriageDateAfterDeath of 'person + | MarriageDateBeforeBirth of 'person + | MotherDeadAfterChildBirth of 'person and 'person + | ParentBornAfterChild of 'person and 'person + | ParentTooYoung of 'person and Def.date + | TitleDatesError of 'person and title istr + | YoungForMarriage of 'person and Def.date ] +; +type base_warning = warning base_person; + +value check_person : + base -> (base_error -> unit) -> (base_warning -> unit) -> base_person -> unit +; + +value check_family : + base -> (base_error -> unit) -> (base_warning -> unit) -> base_family -> + unit +; + +value check_noloop_for_person_list : + base -> (base_error -> unit) -> list (base_person) -> unit +; + +value check_base : + base -> (base_error -> unit) -> (base_warning -> unit) -> unit +; + +value strip_controls_m : string -> string; +value strip_spaces : string -> string; +value valeur_alphabetique : char -> int; +value alphabetique : string -> string -> int; +value initiale : string -> int; diff --git a/src/gwc.ml b/src/gwc.ml new file mode 100644 index 0000000000..53dbc67e8b --- /dev/null +++ b/src/gwc.ml @@ -0,0 +1,554 @@ +(* camlp4r ./pa_lock.cmo *) +(* $Id: gwc.ml,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +open Def; +open Check; +open Gutil; +open Gwcomp; + +value check_magic = + let b = String.create (String.length magic_gwo) in + fun fname ic -> + do really_input ic b 0 (String.length b); return + if b <> magic_gwo then + if String.sub magic_gwo 0 4 = String.sub b 0 4 then + failwith + ("\"" ^ fname ^ "\" is a GeneWeb object file, but not compatible") + else + failwith + ("\"" ^ fname ^ + "\" is not a GeneWeb object file, or it is a very old version") + else () +; + +value no_string gen = ""; + +value unique_string gen x = + try Mhashtbl.find gen.g_strings x with + [ Not_found -> + do if gen.g_scnt == gen.g_base.strings.len then + let arr = gen.g_base.strings.array () in + let new_size = 2 * (Array.length arr) + 1 in + let new_arr = Array.create new_size (no_string gen) in + do Array.blit arr 0 new_arr 0 (Array.length arr); + gen.g_base.strings.array := fun () -> new_arr; + gen.g_base.strings.len := Array.length new_arr; + return () + else (); + return + let u = Adef.istr_of_int gen.g_scnt in + do (gen.g_base.strings.array ()).(gen.g_scnt) := x; + gen.g_scnt := gen.g_scnt + 1; + Mhashtbl.add gen.g_strings x u; + return u ] +; + +value no_family gen = + let empty = unique_string gen "" in + let fam = + {marriage = Adef.codate_None; marriage_place = empty; + divorce = NotDivorced; children = [| |]; comment = empty; + origin_file = empty; fsources = empty; fam_index = Adef.ifam_of_int 0} + and cpl = + {father = Adef.iper_of_int 0; mother = Adef.iper_of_int 0} + in + (fam, cpl) +; + +value faire_personne gen p n occ i = + let empty_string = unique_string gen "" in + let p = + {first_name = unique_string gen p; surname = unique_string gen n; + occ = occ; photo = empty_string; + first_names_aliases = []; surnames_aliases = []; + public_name = empty_string; nick_names = []; + aliases = []; titles = []; occupation = empty_string; + sexe = Neutre; access = IfTitles; + birth = Adef.codate_None; birth_place = empty_string; + baptism = Adef.codate_None; baptism_place = empty_string; + death = DontKnowIfDead; death_place = empty_string; + burial = UnknownBurial; burial_place = empty_string; + family = [| |]; notes = empty_string; + psources = empty_string; cle_index = Adef.iper_of_int i} + and a = + {parents = None; consang = Adef.fix (-1)} + in + (p, a) +; + +value no_person gen = faire_personne gen "" "" 0 0; + +value new_iper gen = + if gen.g_pcnt == gen.g_base.persons.len then + let per_arr = gen.g_base.persons.array () in + let asc_arr = gen.g_base.ascends.array () in + let new_size = 2 * (Array.length per_arr) + 1 in + let (per_bidon, asc_bidon) = no_person gen in + let new_per_arr = Array.create new_size per_bidon in + let new_asc_arr = Array.create new_size asc_bidon in + let new_def = Array.create new_size False in + do Array.blit per_arr 0 new_per_arr 0 (Array.length per_arr); + gen.g_base.persons.array := fun () -> new_per_arr; + gen.g_base.persons.len := Array.length new_per_arr; + Array.blit asc_arr 0 new_asc_arr 0 (Array.length asc_arr); + gen.g_base.ascends.array := fun () -> new_asc_arr; + gen.g_base.ascends.len := Array.length new_asc_arr; + Array.blit gen.g_def 0 new_def 0 (Array.length gen.g_def); + gen.g_def := new_def; + return () + else () +; + +value new_ifam gen = + if gen.g_fcnt == gen.g_base.families.len then + let fam_arr = gen.g_base.families.array () in + let cpl_arr = gen.g_base.couples.array () in + let new_size = 2 * (Array.length fam_arr) + 1 in + let (phony_fam, phony_cpl) = no_family gen in + let new_fam_arr = Array.create new_size phony_fam in + let new_cpl_arr = Array.create new_size phony_cpl in + do Array.blit fam_arr 0 new_fam_arr 0 (Array.length fam_arr); + gen.g_base.families.array := fun () -> new_fam_arr; + gen.g_base.families.len := Array.length new_fam_arr; + Array.blit cpl_arr 0 new_cpl_arr 0 (Array.length cpl_arr); + gen.g_base.couples.array := fun () -> new_cpl_arr; + gen.g_base.couples.len := Array.length new_cpl_arr; + return () + else () +; + +value title_name_unique_string gen = + fun + [ Tmain -> Tmain + | Tname n -> Tname (unique_string gen n) + | Tnone -> Tnone ] +; + +value title_unique_string gen t = + {t_name = title_name_unique_string gen t.t_name; + t_title = unique_string gen t.t_title; + t_place = unique_string gen t.t_place; t_date_start = t.t_date_start; + t_date_end = t.t_date_end; t_nth = t.t_nth} +; + +value find_person_by_name gen first_name surname occ = + let s = Name.strip_lower (first_name ^ "." ^ string_of_int occ ^ surname) in + let key = Hashtbl.hash s in + let ipl = Mhashtbl.find_all gen.g_names key in + let first_name = Name.strip_lower first_name in + let surname = Name.strip_lower surname in + loop ipl where rec loop = + fun + [ [] -> raise Not_found + | [ip :: ipl] -> + let p = poi gen.g_base ip in + if Name.strip_lower (sou gen.g_base p.first_name) = first_name + && Name.strip_lower (sou gen.g_base p.surname) = surname + && p.occ == occ + then ip + else loop ipl ] +; + +value add_person_by_name gen first_name surname occ iper = + let s = Name.strip_lower (first_name ^ "." ^ string_of_int occ ^ surname) in + let key = Hashtbl.hash s in + Mhashtbl.add gen.g_names key iper +; + +value insert_undefined_parent gen key = + let occ = key.pk_occ + gen.g_shift in + let x = + try + if key.pk_first_name = "?" || key.pk_surname = "?" then raise Not_found + else + let x = + find_person_by_name gen key.pk_first_name key.pk_surname occ + in + poi gen.g_base x + with + [ Not_found -> + let (x, a) = + faire_personne gen key.pk_first_name key.pk_surname occ + gen.g_pcnt + in + do if key.pk_first_name <> "?" && key.pk_surname <> "?" then + add_person_by_name gen key.pk_first_name key.pk_surname occ + x.cle_index + else (); + new_iper gen; + (gen.g_base.persons.array ()).(gen.g_pcnt) := x; + (gen.g_base.ascends.array ()).(gen.g_pcnt) := a; + gen.g_pcnt := gen.g_pcnt + 1; + return x ] + in + do if not gen.g_errored then + if sou gen.g_base x.first_name <> key.pk_first_name || + sou gen.g_base x.surname <> key.pk_surname then + do Printf.eprintf "\nPersonne définie avec deux orthographes:\n"; + Printf.eprintf " \"%s%s %s\"\n" key.pk_first_name + (match x.occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + key.pk_surname; + Printf.eprintf " \"%s%s %s\"\n" (sou gen.g_base x.first_name) + (match occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + (sou gen.g_base x.surname); + gen.g_def.(Adef.int_of_iper x.cle_index) := True; + return Check.error gen + else () + else (); + return x +; + +value insert_person gen so = + let occ = so.occ + gen.g_shift in + let x = + try + if so.first_name = "?" || so.surname = "?" then raise Not_found + else + let x = + find_person_by_name gen so.first_name so.surname occ + in + poi gen.g_base x + with + [ Not_found -> + let (x, a) = + faire_personne gen so.first_name so.surname occ gen.g_pcnt + in + do if so.first_name <> "?" && so.surname <> "?" then + add_person_by_name gen so.first_name so.surname occ + x.cle_index + else (); + new_iper gen; + (gen.g_base.persons.array ()).(gen.g_pcnt) := x; + (gen.g_base.ascends.array ()).(gen.g_pcnt) := a; + gen.g_pcnt := gen.g_pcnt + 1; + return x ] + in + do if gen.g_def.(Adef.int_of_iper x.cle_index) then + do Printf.eprintf "\nPersonne déja définie: \"%s%s %s\"\n" + so.first_name + (match x.occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + so.surname; + if sou gen.g_base x.first_name <> so.first_name || + sou gen.g_base x.surname <> so.surname then + Printf.eprintf "sous le nom: \"%s%s %s\"\n" + (sou gen.g_base x.first_name) + (match occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + (sou gen.g_base x.surname) + else (); + x.birth := Adef.codate_None; + x.death := DontKnowIfDead; + return Check.error gen + else gen.g_def.(Adef.int_of_iper x.cle_index) := True; + if not gen.g_errored then + if sou gen.g_base x.first_name <> so.first_name || + sou gen.g_base x.surname <> so.surname then + do Printf.eprintf "\nPersonne définie avec deux orthographes:\n"; + Printf.eprintf " \"%s%s %s\"\n" so.first_name + (match x.occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + so.surname; + Printf.eprintf " \"%s%s %s\"\n" (sou gen.g_base x.first_name) + (match occ with + [ 0 -> "" + | n -> "." ^ string_of_int n ]) + (sou gen.g_base x.surname); + gen.g_def.(Adef.int_of_iper x.cle_index) := True; + return Check.error gen + else () + else (); + if not gen.g_errored then + do x.birth := so.birth; + x.birth_place := unique_string gen so.birth_place; + x.baptism := so.baptism; + x.baptism_place := unique_string gen so.baptism_place; + x.death := so.death; + x.death_place := unique_string gen so.death_place; + x.burial := so.burial; + x.burial_place := unique_string gen so.burial_place; + x.first_names_aliases := + List.map (unique_string gen) so.first_names_aliases; + x.surnames_aliases := + List.map (unique_string gen) so.surnames_aliases; + x.public_name := unique_string gen so.public_name; + x.photo := unique_string gen so.photo; + x.nick_names := List.map (unique_string gen) so.nick_names; + x.aliases := List.map (unique_string gen) so.aliases; + x.titles := List.map (title_unique_string gen) so.titles; + x.access := so.access; + x.occupation := unique_string gen so.occupation; + x.psources := unique_string gen so.psources; + return () + else (); + return x +; + +value insert_parent gen = + fun + [ Undefined key -> insert_undefined_parent gen key + | Defined so -> insert_person gen so ] +; + +value verif_parents_non_deja_definis gen x pere mere = + match (aoi gen.g_base x.cle_index).parents with + [ Some ifam -> + let cpl = coi gen.g_base ifam in + let p = cpl.father in + let m = cpl.mother in + do Printf.eprintf + " +Je ne peux pas ajouter \"%s\", enfant de + - \"%s\" + - \"%s\", +parce que cette personne existe deja en tant qu'enfant de + - \"%s\" + - \"%s\". +" (denomination gen.g_base x) (denomination gen.g_base pere) + (denomination gen.g_base mere) + (denomination gen.g_base (poi gen.g_base p)) + (denomination gen.g_base (poi gen.g_base m)); + flush stderr; + x.birth := Adef.codate_None; + x.death := DontKnowIfDead; + return Check.error gen + | _ -> () ] +; + +value noter_sexe gen p s = + if p.sexe == Neutre then p.sexe := s + else if p.sexe == s || s == Neutre then () + else + do Printf.eprintf "\nIncohérence sur le sexe de\n %s %s\n" + (sou gen.g_base p.first_name) (sou gen.g_base p.surname); + return Check.error gen +; + +value insere_famille gen co fo = + let pere = insert_parent gen co.father in + let mere = insert_parent gen co.mother in + let children = + Array.map + (fun cle -> + let e = insert_person gen cle in + do noter_sexe gen e cle.sexe; return e.cle_index) + fo.children + in + let comment = unique_string gen fo.comment in + let fsources = unique_string gen fo.fsources in + do new_ifam gen; return + let fam = + {marriage = fo.marriage; + marriage_place = unique_string gen fo.marriage_place; + children = children; divorce = fo.divorce; + comment = comment; origin_file = unique_string gen fo.origin_file; + fsources = fsources; fam_index = Adef.ifam_of_int gen.g_fcnt} + and cpl = + {father = pere.cle_index; mother = mere.cle_index} + in + do (gen.g_base.families.array ()).(gen.g_fcnt) := fam; + (gen.g_base.couples.array ()).(gen.g_fcnt) := cpl; + gen.g_fcnt := gen.g_fcnt + 1; + pere.family := Array.append pere.family [| fam.fam_index |]; + mere.family := Array.append mere.family [| fam.fam_index |]; + noter_sexe gen pere Masculin; + noter_sexe gen mere Feminin; + Array.iter + (fun ix -> + let x = poi gen.g_base ix in + let a = aoi gen.g_base ix in + do verif_parents_non_deja_definis gen x pere mere; + a.parents := Some fam.fam_index; + return ()) + children; + return () +; + +value insere_notes fname gen key str = + let occ = key.pk_occ + gen.g_shift in + match + try + Some + (find_person_by_name gen key.pk_first_name key.pk_surname occ) + with [ Not_found -> None ] + with + [ Some ip -> + let p = poi gen.g_base ip in + if sou gen.g_base p.notes <> "" then + do Printf.eprintf "\nFile \"%s\"\n" fname; + Printf.eprintf "Notes already defined for \"%s%s %s\"\n" + key.pk_first_name + (if occ == 0 then "" else "." ^ string_of_int occ) + key.pk_surname; + return Check.error gen + else + p.notes := unique_string gen str + | None -> + do Printf.eprintf "File \"%s\"\n" fname; + Printf.eprintf "Notes before person definition: \"%s%s %s\"\n" + key.pk_first_name + (if occ == 0 then "" else "." ^ string_of_int occ) + key.pk_surname; + flush stderr; + return Check.error gen ] +; + +value insere_syntax fname gen = + fun + [ Family cpl fam -> insere_famille gen cpl fam + | Notes key str -> insere_notes fname gen key str ] +; + +value insere_comp_familles gen (x, shift) = + let ic = open_in_bin x in + do check_magic x ic; + gen.g_shift := shift; + return + let (src, fams) = (input_value ic : Gwcomp.gwo) in + do List.iter (insere_syntax src gen) fams; return close_in ic +; + +value just_comp = ref False; +value do_check = ref True; +value out_file = ref "a"; +value do_consang = ref False; +value pr_stats = ref False; + +value cache_of tab = + let c = + {array = fun _ -> tab; get = fun []; len = Array.length tab} + in + do c.get := fun i -> (c.array ()).(i); return c +; + +value link gwo_list = + let no_istr_iper_index = {find = fun []; cursor = fun []; next = fun []} in + let gen = + {g_strings = Mhashtbl.create 20011; + g_names = Mhashtbl.create 20011; + g_pcnt = 0; g_fcnt = 0; g_scnt = 0; + g_base = + {persons = cache_of [| |]; + ascends = cache_of [| |]; + families = cache_of [| |]; + couples = cache_of [| |]; + strings = cache_of [| |]; + has_family_patches = False; + persons_of_name = fun []; + strings_of_fsname = fun []; + index_of_string = fun []; + persons_of_surname = no_istr_iper_index; + persons_of_first_name = no_istr_iper_index; + patch_person = fun []; patch_ascend = fun []; + patch_family = fun []; patch_couple = fun []; + patch_string = fun []; + patch_name = fun []; commit_patches = fun []; cleanup = fun () -> ()}; + g_def = [| |]; g_shift = 0; g_errored = False} + in + do List.iter (insere_comp_familles gen) gwo_list; return + let persons = Array.sub (gen.g_base.persons.array ()) 0 gen.g_pcnt in + do gen.g_base.persons.array := fun _ -> [| |]; return + let ascends = Array.sub (gen.g_base.ascends.array ()) 0 gen.g_pcnt in + do gen.g_base.ascends.array := fun _ -> [| |]; return + let families = Array.sub (gen.g_base.families.array ()) 0 gen.g_fcnt in + do gen.g_base.families.array := fun _ -> [| |]; return + let couples = Array.sub (gen.g_base.couples.array ()) 0 gen.g_fcnt in + do gen.g_base.couples.array := fun _ -> [| |]; return + let strings = Array.sub (gen.g_base.strings.array ()) 0 gen.g_scnt in + do gen.g_base.strings.array := fun _ -> [| |]; return + let base = + {persons = cache_of persons; + ascends = cache_of ascends; + families = cache_of families; + couples = cache_of couples; + strings = cache_of strings; + has_family_patches = False; + persons_of_name = fun []; + strings_of_fsname = fun []; + index_of_string = fun []; + persons_of_surname = no_istr_iper_index; + persons_of_first_name = no_istr_iper_index; + patch_person = fun []; patch_ascend = fun []; + patch_family = fun []; patch_couple = fun []; + patch_string = fun []; patch_name = fun []; commit_patches = fun []; + cleanup = fun () -> ()} + in + do if do_check.val && Array.length persons > 0 then + do Check.check_base base gen pr_stats.val; flush stderr; return () + else (); + if not gen.g_errored then + if do_consang.val then Consang.compute_all_consang base False + else () + else exit 1; + return base +; + +value shift = ref 0; + +value main () = + let files = ref [] in + do Argl.parse + [("-c", Arg.Set just_comp, "Only compiling"); + ("-o", Arg.String (fun s -> out_file.val := s), + " Output data base (default: a.gwb)"); + ("-stats", Arg.Set pr_stats, "Print statistics"); + ("-nc", Arg.Clear do_check, "No consistency check"); + ("-cg", Arg.Set do_consang, "Compute consanguinity"); + ("-sh", Arg.Int (fun x -> shift.val := x), + " Shift all persons numbers")] + (fun x -> + do if Filename.check_suffix x ".gw" then () + else if Filename.check_suffix x ".gwo" then () + else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\"")); + return files.val := [(x, shift.val) :: files.val]) + "Usage: gwc [options] [files] +where [files] are a list of files: + source files end with .gw + object files end with .gwo +and [options] are:"; + return + let gwo = ref [] in + do List.iter + (fun (x, shift) -> + if Filename.check_suffix x ".gw" then + do try Gwcomp.comp_familles x with e -> + do Printf.eprintf "File \"%s\", line %d:\n" x line_cnt.val; + return raise e; + gwo.val := [(x ^ "o", shift) :: gwo.val]; + return () + else if Filename.check_suffix x ".gwo" then + gwo.val := [(x, shift) :: gwo.val] + else raise (Arg.Bad ("Don't know what to do with \"" ^ x ^ "\""))) + (List.rev files.val); + if not just_comp.val then + lock (Iobase.lock_file out_file.val) with + [ Accept -> + let base = link (List.rev gwo.val) in + do Gc.compact (); + Iobase.output out_file.val base; + return () + | Refuse -> + do Printf.eprintf "Base is locked: cannot write it\n"; + flush stderr; + return exit 2 ] + else (); + return () +; + +value print_exc = + fun + [ Failure txt -> + do Printf.eprintf "Failed: %s\n" txt; + flush stderr; + return exit 2 + | exc -> Printexc.catch raise exc ] +; + +try main () with exc -> print_exc exc; diff --git a/src/gwcomp.ml b/src/gwcomp.ml new file mode 100644 index 0000000000..64e4ca7b9d --- /dev/null +++ b/src/gwcomp.ml @@ -0,0 +1,710 @@ +(* $Id: gwcomp.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +open Def; +open Gutil; + +value magic_gwo = "GnWo0008"; + +type key = + { pk_first_name : string; + pk_surname : string; + pk_occ : int } +; + +type somebody = + [ Undefined of key + | Defined of Def.person string ] +; + +type syntax_o = + [ Family of couple somebody and Def.family (Def.person string) string + | Notes of key and string ] +; + +type gwo = (string * list syntax_o); + +value copy_decode s i1 i2 = + let rec loop_copy t i j = + if i < i2 then + let c = + match s.[i] with + [ '_' -> ' ' + | x -> x ] + in + do t.[j] := c; return loop_copy t (succ i) (succ j) + else t + in + loop_copy (String.create (i2 - i1)) i1 0 +; + +value fields str = + loop 0 0 where rec loop beg i = + if i < String.length str then + if str.[i] == ' ' then + if beg == i then loop (succ beg) (succ i) + else [copy_decode str beg i :: loop (succ i) (succ i)] + else loop beg (succ i) + else if beg == i then [] + else [copy_decode str beg i] +; + +value date_de_string s i = + let champ i = + let (neg, i) = + if i < String.length s && s.[i] == '-' then (True, i + 1) else (False, i) + in + loop i 0 where rec loop i n = + if i == String.length s then (if neg then - n else n, i) + else + match s.[i] with + [ '0'..'9' as c -> + loop (succ i) (10 * n + Char.code c - Char.code '0') + | _ -> (if neg then - n else n, i) ] + in + let skip_slash i = + if s.[i] == '/' then succ i else failwith ("date_de_string " ^ s) + in + let (precision, i) = + match s.[i] with + [ '~' -> (About, succ i) + | '?' -> (Maybe, succ i) + | '>' -> (After, succ i) + | '<' -> (Before, succ i) + | _ -> (Sure, i) ] + in + let (undef, annee, i) = + let (annee, j) = champ i in + if j = i + 1 && s.[i] == '0' then (True, annee, j) + else (False, annee, j) + in + let (precision, i) = + if i < String.length s && s.[i] == '|' then + let (y2, i) = champ (succ i) in (OrYear y2, i) + else (precision, i) + in + if i == String.length s then + if undef then None else Some (Da precision annee) + else + let i = skip_slash i in + let mois = annee in + let (annee, i) = champ i in + if i == String.length s then + if annee == 0 then None + else if mois < 1 || mois > 12 then failwith ("date_de_string " ^ s) + else Some (Dma mois annee) + else + let i = skip_slash i in + let jour = mois in + let mois = annee in + let (annee, i) = champ i in + if i == String.length s then + if annee == 0 then None + else if mois < 1 || mois > 12 then failwith ("date_de_string " ^ s) + else if jour < 1 || jour > 31 then failwith ("date_de_string " ^ s) + else Some (Djma jour mois annee) + else failwith ("date_de_string " ^ s) +; + +value rindex s c = + pos (String.length s - 1) where rec pos i = + if i < 0 then None else if s.[i] = c then Some i else pos (i - 1) +; + +value line_cnt = ref 0; + +value input_a_line ic = + let x = input_line ic in + do incr line_cnt; return x +; + +value rec input_real_line ic = + let x = input_line ic in + do incr line_cnt; return + if x = "" || x.[0] == '#' then input_real_line ic else x +; + +value get_optional_birthdate l = + match l with + [ ["" :: _] -> (None, l) + | [x :: l'] -> + let i = 0 in + if x.[i] == '!' then (None, l) + else + match x.[i] with + [ '~' | '?' | '<' | '>' | '-' | '0'..'9' -> + let d = date_de_string x i in + (Some d, l') + | _ -> (None, l) ] + | _ -> (None, l) ] +; + +value get_optional_baptdate l = + match l with + [ [x :: l'] -> + let i = 0 in + if x.[i] == '!' then + let i = succ i in + match x.[i] with + [ '~' | '?' | '<' | '>' | '-' | '0'..'9' -> + let d = date_de_string x i in + (Some d, l') + | _ -> (None, l) ] + else (None, l) + | _ -> (None, l) ] +; + +value get_optional_deathdate l = + match l with + [ ["?" :: l'] -> (Some DontKnowIfDead, l') + | ["mj" :: l'] -> (Some DeadYoung, l') + | [x :: l'] -> + let i = 0 in + let (dr, i) = + match x.[i] with + [ 'k' -> (Killed, i + 1) + | 'm' -> (Murdered, i + 1) + | 'e' -> (Executed, i + 1) + | 's' -> (Disappeared, i + 1) + | _ -> (Unspecified, i) ] + in + if i < String.length x then + match x.[i] with + [ '~' | '?' | '>' | '<' | '-' | '0'..'9' -> + let d = + match date_de_string x i with + [ None -> DeadDontKnowWhen + | Some d -> Death dr (Adef.cdate_of_date d) ] + in + (Some d, l') + | _ -> (None, l) ] + else (None, l) + | _ -> (None, l) ] +; + +value get_burial l = + match l with + [ ["#buri" :: l] -> + match l with + [ [x :: l'] -> + let i = 0 in + let (od, l) = + match x.[i] with + [ '~' | '?' | '>' | '<' | '-' | '0'..'9' -> + (date_de_string x i, l') + | _ -> (None, l) ] + in + (Buried (Adef.codate_of_od od), l) + | [] -> (Buried Adef.codate_None, l) ] + | ["#crem" :: l] -> + match l with + [ [x :: l'] -> + let i = 0 in + let (od, l) = + match x.[i] with + [ '~' | '?' | '>' | '<' | '-' | '0'..'9' -> + (date_de_string x i, l') + | _ -> (None, l) ] + in + (Cremated (Adef.codate_of_od od), l) + | [] -> (Cremated Adef.codate_None, l) ] + | _ -> (UnknownBurial, l) ] +; + +value get_birth_place l = + match l with + [ ["#bp"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value get_bapt_place l = + match l with + [ ["#pp"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value get_death_place l = + match l with + [ ["#dp"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value get_burial_place l = + match l with + [ ["#rp"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value get_optional_sexe = + fun + [ ["h" :: l] -> (Masculin, l) + | ["f" :: l] -> (Feminin, l) + | l -> (Neutre, l) ] +; + +value make_int str x = + loop False 0 where rec loop found n i = + if i == String.length x then + if found then n else raise Not_found + else + match x.[i] with + [ '0'..'9' as c -> + loop True (10 * n + Char.code c - Char.code '0') (succ i) + | _ -> raise Not_found ] +; + +value cut_space x = + if String.length x > 0 && x.[0] == ' ' then + String.sub x 1 (String.length x - 1) + else x +; + +value get_fst_name str l = + match l with + [ [x :: l'] -> + match x.[0] with + [ 'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' | '[' | '0'..'9' | '?' + | ' ' -> + let x = cut_space x in + let (x, occ) = + match rindex x '.' with + [ Some i -> + try (String.sub x 0 i, make_int str x (succ i)) with + [ Not_found -> (x, 0) ] + | None -> (x, 0) ] + in + (x, occ, l') + | _ -> failwith str ] + | _ -> failwith str ] +; + +value rec get_fst_names_aliases str l = + match l with + [ [x :: l'] -> + if x.[0] == '{' && x.[String.length x - 1] == '}' then + let n = String.sub x 1 (String.length x - 2) in + let (nl, l) = get_fst_names_aliases str l' in ([n :: nl], l) + else ([], l) + | [] -> ([], l) ] +; + +value rec get_surnames_aliases str l = + match l with + [ ["#salias"; x :: l'] -> + let (nl, l) = get_surnames_aliases str l' in ([x :: nl], l) + | _ -> ([], l) ] +; + +value rec get_nick_names str l = + match l with + [ ["#nick"; x :: l'] -> + let (nl, l) = get_nick_names str l' in ([x :: nl], l) + | _ -> ([], l) ] +; + +value rec get_aliases str l = + match l with + [ ["#alias"; x :: l'] -> let (nl, l) = get_aliases str l' in ([x :: nl], l) + | _ -> ([], l) ] +; + +value get_name str l = + match l with + [ ["#nick" :: _] | ["#alias" :: _] -> ("", l) + | [x :: l'] -> + match x.[0] with + [ '{' -> ("", l) + | 'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' | '0'..'9' | '?' | ' ' -> + (cut_space x, l') + | _ -> ("", l) ] + | _ -> ("", l) ] +; + +value get_pub_name str l = + match l with + [ [x :: l'] -> + if x.[0] == '(' && x.[String.length x - 1] == ')' then + let a = String.sub x 1 (String.length x - 2) in (a, l') + else ("", l) + | _ -> ("", l) ] +; + +value get_photo str l = + match l with + [ ["#photo"; x :: l'] -> + do for i = 0 to String.length x - 1 do + if x.[i] == ' ' then x.[i] := '_' else (); + done; + return (x, l') + | _ -> ("", l) ] +; + +value get_occu str l = + match l with + [ ["#occu"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value get_sources str l = + match l with + [ ["#src"; x :: l'] -> (x, l') + | _ -> ("", l) ] +; + +value rec get_access str l = + match l with + [ ["#apubl" :: l'] -> (Public, l') + | ["#apriv" :: l'] -> (Private, l') + | _ -> (IfTitles, l) ] +; + +value scan_title t = + let i = 0 in + let (name, i) = + loop "" i where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i + 1) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else failwith t + in + let name = + match name with + [ "" -> Tnone + | "*" -> Tmain + | _ -> Tname name ] + in + let (title, i) = + loop "" i where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i + 1) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else failwith t + in + let (place, i) = + loop "" i where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i) +(* + | '0'..'9' -> failwith t +*) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else (s, i) + in + let (date_start, i) = + if i < String.length t && t.[i] == ':' then + let (d, i) = + loop "" (i + 1) where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else (s, i) + in + (if d <> "" then date_de_string d 0 else None, i) + else (None, i) + in + let (date_end, i) = + if i < String.length t && t.[i] == ':' then + let (d, i) = + loop "" (i + 1) where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else (s, i) + in + (if d <> "" then date_de_string d 0 else None, i) + else (None, i) + in + let (nth, i) = + if i < String.length t && t.[i] == ':' then + let (d, i) = + loop "" (i + 1) where rec loop s i = + if i < String.length t then + match t.[i] with + [ ':' -> (s, i) + | c -> loop (s ^ String.make 1 c) (i + 1) ] + else (s, i) + in + (if d <> "" then int_of_string d else 0, i) + else (0, i) + in + if i <> String.length t then failwith t + else + {t_name = name; t_title = title; t_place = place; + t_date_start = Adef.codate_of_od date_start; + t_date_end = Adef.codate_of_od date_end; + t_nth = nth} +; + +value rec get_titles str l = + match l with + [ [x :: l'] -> + if x.[0] == '[' && x.[String.length x - 1] == ']' then + let t = String.sub x 1 (String.length x - 2) in + let t = scan_title t in + let (al, l') = get_titles str l' in ([t :: al], l') + else ([], l) + | _ -> ([], l) ] +; + +value get_mar_date str = + fun + [ [x :: l] -> + let (mar, l) = + match x.[0] with + [ '+' -> + (if String.length x > 1 then + Adef.codate_of_od (date_de_string x 1) + else Adef.codate_None, l) + | _ -> failwith str ] + in + let (place, l) = + match l with + [ ["#mp"; x :: l] -> (x, l) + | _ -> ("", l) ] + in + let (divorce, l) = + match l with + [ [x :: l] when x.[0] == '-' -> + if String.length x > 1 then + (Divorced (Adef.codate_of_od (date_de_string x 1)), l) + else (Divorced Adef.codate_None, l) + | _ -> (NotDivorced, l) ] + in + (mar, place, divorce, l) + | [] -> failwith str ] +; + +value lire_ligne ic = + try let str = input_real_line ic in Some (str, fields str) with + [ End_of_file -> None ] +; + +value create_person () = + {first_name = ""; surname = ""; occ = 0; photo = ""; + public_name = ""; nick_names = []; aliases = []; + first_names_aliases = []; surnames_aliases = []; + titles = []; occupation = ""; sexe = Neutre; access = IfTitles; + birth = Adef.codate_None; birth_place = ""; + baptism = Adef.codate_None; baptism_place = ""; + death = DontKnowIfDead; death_place = ""; + burial = UnknownBurial; burial_place = ""; + family = [| |]; notes = ""; psources = ""; + cle_index = Adef.iper_of_int (-1)} +; + +value bogus_def p n o = p = "?" || n = "?"; + +value set_infos str u l = + let (nl, l) = get_fst_names_aliases str l in + do u.first_names_aliases := nl; return + let (nl, l) = get_surnames_aliases str l in + do u.surnames_aliases := nl; return + let (n, l) = get_pub_name str l in + do u.public_name := n; return + let (n, l) = get_photo str l in + do u.photo := n; return + let (nl, l) = get_nick_names str l in + do u.nick_names := nl; return + let (nl, l) = get_aliases str l in + do u.aliases := nl; return + let (tl, l) = get_titles str l in + do u.titles := tl; return + let (n, l) = get_access str l in + do u.access := n; return + let (n, l) = get_occu str l in + do u.occupation := n; return + let (n, l) = get_sources str l in + do if n <> "" then u.psources := n else (); return + let (naissance, l) = get_optional_birthdate l in + let (birth_place, l) = get_birth_place l in + let (baptism, l) = get_optional_baptdate l in + let (baptism_place, l) = get_bapt_place l in + let (mort, l) = get_optional_deathdate l in + let (death_place, l) = get_death_place l in + let mort = + match (naissance, mort) with + [ (None, _) | (_, Some _) | (Some None, _) -> + match mort with + [ Some m -> m + | None -> DontKnowIfDead ] + | (Some _, None) -> NotDead ] + in + let naissance = + match naissance with + [ None -> Adef.codate_None + | Some x -> Adef.codate_of_od x ] + in + let baptism = + match baptism with + [ None -> Adef.codate_None + | Some x -> Adef.codate_of_od x ] + in + do u.birth := naissance; + u.birth_place := birth_place; + u.baptism := baptism; + u.baptism_place := baptism_place; + u.death := mort; + u.death_place := death_place; + return + let (burial, l) = get_burial l in + do u.burial := burial; return + let (burial_place, l) = get_burial_place l in + do u.burial_place := burial_place; return + l +; + +value parse_parent str l = + let (np, l) = get_name str l in + let (pp, op, l) = get_fst_name str l in + let defined = + if bogus_def pp np op then True + else + match l with + [ [] -> False + | [s :: _] when s.[0] = '+' -> False + | _ -> True ] + in + if not defined then + let key = {pk_first_name = pp; pk_surname = np; pk_occ = op} in + (Undefined key, np, l) + else + let u = create_person () in + do u.surname := np; + u.first_name := pp; u.occ := op; + return + let l = set_infos str u l in + (Defined u, np, l) +; + +value parse_child str surname csrc l = + let u = create_person () in + let (prenom, occ, l) = get_fst_name str l in + do u.first_name := prenom; u.occ := occ; return + let (nom, l) = + match l with + [ ["?" :: _] -> get_name str l + | [x :: l'] -> + match x.[0] with + [ '<' | '>' | '!' | '~' | '?' | '-' | '0'..'9' | '{' | '#' -> + (surname, l) + | '(' | '[' -> (if prenom = "" then "" else surname, l) + | _ -> get_name str l ] + | _ -> (surname, []) ] + in + do u.surname := nom; + u.psources := csrc; + return + let l = set_infos str u l in (u, l) +; + +value lire_famille ic fname = + fun + [ Some (str, ["fam" :: l]) -> + let (cle_pere, surname, l) = parse_parent str l in + let (marriage, marriage_place, divorce, l) = get_mar_date str l in + let (cle_mere, _, l) = parse_parent str l in + do if l <> [] then failwith str else (); return + let ligne = lire_ligne ic in + let (fsrc, ligne) = + match ligne with + [ Some (str, ["src"; x]) -> (x, lire_ligne ic) + | Some (str, ["src" :: _]) -> failwith str + | _ -> ("", ligne) ] + in + let (csrc, ligne) = + match ligne with + [ Some (str, ["csrc"; x]) -> (x, lire_ligne ic) + | Some (str, ["csrc" :: _]) -> failwith str + | _ -> ("", ligne) ] + in + let co = {father = cle_pere; mother = cle_mere} in + match ligne with + [ Some (_, ["beg"]) -> + let cles_enfants = + let rec loop children = + match lire_ligne ic with + [ Some (str, ["-" :: l]) -> + let (sexe, l) = get_optional_sexe l in + let (child, l) = parse_child str surname csrc l in + do child.sexe := sexe; return + if l <> [] then failwith str + else loop [child :: children] + | Some (str, ["end"]) -> children + | Some (str, _) -> failwith str + | _ -> failwith "eof" ] + in + List.rev (loop []) + in + let fo = + {marriage = marriage; marriage_place = marriage_place; + divorce = divorce; children = Array.of_list cles_enfants; + comment = ""; origin_file = fname; fsources = fsrc; + fam_index = Adef.ifam_of_int (-1)} + in + Some (Family co fo, lire_ligne ic) + | Some (str, ["comm" :: _]) -> + let comm = String.sub str 5 (String.length str - 5) in + let fo = + {marriage = marriage; marriage_place = marriage_place; + divorce = divorce; children = [||]; comment = comm; + origin_file = fname; fsources = fsrc; + fam_index = Adef.ifam_of_int (-1)} + in + Some (Family co fo, lire_ligne ic) + | ligne -> + let fo = + {marriage = marriage; marriage_place = marriage_place; + divorce = divorce; children = [||]; comment = ""; + origin_file = fname; fsources = fsrc; + fam_index = Adef.ifam_of_int (-1)} + in + Some (Family co fo, ligne) ] + | Some (str, ["notes" :: l]) -> + let (surname, l) = get_name str l in + let (first_name, occ, l) = get_fst_name str l in + if l <> [] then failwith "str" + else + match lire_ligne ic with + [ Some (_, ["beg"]) -> + let notes = + try + loop (input_a_line ic) where rec loop = + fun + [ "end notes" -> "" + | l -> l ^ "\n" ^ loop (input_a_line ic) ] + with + [ End_of_file -> failwith "end of file" ] + in + let key = + {pk_first_name = first_name; + pk_surname = surname; + pk_occ = occ} + in + let str = strip_spaces (strip_controls_m notes) in + Some (Notes key str, lire_ligne ic) + | Some (str, _) -> failwith str + | None -> failwith "end of file" ] + | Some (str, _) -> failwith str + | None -> None ] +; + +value comp_familles x = + do line_cnt.val := 0; return + let ic = open_in x in + let rec boucle fams ligne = + match lire_famille ic x ligne with + [ Some (famille, ligne) -> boucle [famille :: fams] ligne + | None -> fams ] + in + let familles = List.rev (boucle [] (lire_ligne ic)) in + do close_in ic; return + let oc = open_out_bin (Filename.chop_suffix x ".gw" ^ ".gwo") in + do output_string oc magic_gwo; + output_value oc ((x, familles) : gwo); + close_out oc; + return () +; diff --git a/src/gwd.ml b/src/gwd.ml new file mode 100644 index 0000000000..933e0626f6 --- /dev/null +++ b/src/gwd.ml @@ -0,0 +1,654 @@ +(* camlp4r pa_extend.cmo *) +(* $Id: gwd.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Unix; + +value port_selected = ref 2317; +value wizard_passwd = ref ""; +value friend_passwd = ref ""; +value only_address = ref ""; +value cgi = ref False; +value default_lang = ref "fr"; +value log_file = ref ""; +value log_flags = + [Open_wronly; Open_append; Open_creat; Open_text; Open_nonblock] +; +ifdef UNIX then +value max_clients = ref None; +value robot_xcl = ref None; +value auth_file = ref ""; + +value log_oc () = + if log_file.val <> "" then open_out_gen log_flags 0o644 log_file.val + else Pervasives.stderr +; + +value flush_log oc = + if log_file.val <> "" then close_out oc else flush oc +; + +value log from request s = + let referer = Wserver.extract_param "referer: " '\n' request in + let user_agent = Wserver.extract_param "user-agent: " '\n' request in + let oc = log_oc () in + do let tm = Unix.localtime (Unix.time ()) in + Printf.fprintf oc "%02d/%02d/%4d %02d:%02d:%02d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour + tm.Unix.tm_min tm.Unix.tm_sec; + Printf.fprintf oc " %s\n" s; + Printf.fprintf oc " From: %s\n" from; + Printf.fprintf oc " Agent: %s\n" user_agent; + if referer <> "" then Printf.fprintf oc " Referer: %s\n" referer else (); + flush_log oc; + return () +; + +value nl () = + Wserver.wprint "\r\n" +; + +value refuse_log from cgi = + let oc = open_out_gen log_flags 0o644 "refuse_log" in + do let tm = Unix.localtime (Unix.time ()) in + Printf.fprintf oc "%02d/%02d/%4d %02d:%02d:%02d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour + tm.Unix.tm_min tm.Unix.tm_sec; + Printf.fprintf oc " excluded: %s\n" from; + close_out oc; + if cgi then + do Wserver.wprint "HTTP/1.0 403 Forbidden"; nl (); nl (); return () + else (); + Wserver.wprint "Your access has been disconnected by administrator.\n"; + return () +; + +value only_log from cgi = + let oc = log_oc () in + do let tm = Unix.localtime (Unix.time ()) in + Printf.fprintf oc "%02d/%02d/%4d %02d:%02d:%02d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour + tm.Unix.tm_min tm.Unix.tm_sec; + Printf.fprintf oc " Connection refused from %s (only %s)\n" + from only_address.val; + flush_log oc; + if cgi then + do Wserver.wprint "Content-type: text/html; charset=iso-8859-1"; + nl (); nl (); + return () + else Wserver.html (); + Wserver.wprint "Invalid access\n"; + Wserver.wprint "

      Invalid access

      \n"; + return () +; + +value refuse_auth from auth = + let oc = log_oc () in + do let tm = Unix.localtime (Unix.time ()) in + Printf.fprintf oc "%02d/%02d/%4d %02d:%02d:%02d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour + tm.Unix.tm_min tm.Unix.tm_sec; + Printf.fprintf oc " Access failed from %s = %s\n" from auth; + flush_log oc; + Wserver.wprint "HTTP/1.0 401 Unauthorized"; nl (); + Wserver.wprint "WWW-Authenticate: Basic realm=\"Private\""; + nl (); nl (); + Wserver.wprint "Access failed\n"; + Wserver.wprint "

      Access failed

      \n"; + return () +; + +value index c s = + loop 0 where rec loop i = + if i == String.length s then i else if s.[i] == c then i else loop (i + 1) +; + +value rec extract_assoc key = + fun + [ [] -> ("", []) + | [((k, v) as kv) :: kvl] -> + if k = key then (v, kvl) + else + let (v, kvl) = extract_assoc key kvl in + (v, [kv :: kvl]) ] +; + +value input_lexicon lang = + let t = Hashtbl.create 501 in + try + let ic = + open_in + (List.fold_right Filename.concat [Util.lang_dir.val; "lang"] + "lexicon.txt") + in + let pref = lang ^ ": " in + try + do try + while True do + let k = input_line ic in + loop (input_line ic) where rec loop line = + if line = "" then () + else + do if String.sub line 0 4 = pref then + Hashtbl.add t (String.sub k 4 (String.length k - 4)) + (String.sub line 4 (String.length line - 4)) + else (); + return loop (input_line ic); + done + with [ End_of_file -> () ]; + close_in ic; + return t + with e -> do close_in ic; return raise e + with + [ Sys_error _ -> t ] +; + +value rec cut_at_equal i s = + if i = String.length s then (s, "") + else if s.[i] == '=' then + (String.sub s 0 i, String.sub s (succ i) (String.length s - succ i)) + else cut_at_equal (succ i) s +; + +value read_base_env bname = + let fname = Filename.concat Util.base_dir.val bname ^ ".cnf" in + match try Some (open_in fname) with [ Sys_error _ -> None ] with + [ Some ic -> + let env = + loop [] where rec loop env = + match try Some (input_line ic) with [ End_of_file -> None ] with + [ Some s -> + if s = "" || s.[0] = '#' then loop env + else loop [cut_at_equal 0 s :: env] + | None -> + env ] + in + env + | None -> [] ] +; + +type choice 'a 'b = [ Left of 'a | Right of 'b ]; + +value start_with_base conf bname = + let bfile = Filename.concat Util.base_dir.val bname in + match try Left (Iobase.input bfile) with e -> Right e with + [ Left base -> + do Family.family conf base; + Wserver.wflush (); + return () + | Right e -> + let transl conf w = + try Hashtbl.find conf.lexicon w with [ Not_found -> "[" ^ w ^ "]" ] + in + let title _ = + Wserver.wprint "%s" (Util.capitale (transl conf "error")) + in + do Util.header conf title; + Wserver.wprint "
      • %s" + (Util.capitale (transl conf "cannot access base")); + Wserver.wprint " \"%s\".
      \n" conf.bname; + match e with + [ Failure s -> + Wserver.wprint + "Internal message: %s\n" s + | _ -> () ]; + Wserver.wprint "\n"; + return () ] +; + +value propose_base conf = + let title _ = Wserver.wprint "Base" in + do Util.header conf title; + Wserver.wprint "
      • \n"; + Wserver.wprint "
        \n" conf.command; + Wserver.wprint " =>\n"; + Wserver.wprint "\n"; + Wserver.wprint "
      \n"; + Util.trailer conf; + return () +; + +value connection_accepted cgi (addr, request) str env = + let tm = Unix.localtime (Unix.time ()) in + let iq = index '?' str in + let (command, base_file, passwd, env) = + let (base_passwd, env) = + let (x, env) = extract_assoc "b" env in + if x <> "" || cgi then (x, env) else (String.sub str 0 iq, env) + in + let ip = index '_' base_passwd in + let base_file = String.sub base_passwd 0 ip in + let (passwd, env) = + let has_passwd = List.mem_assoc "w" env in + let (x, env) = extract_assoc "w" env in + if has_passwd then (x, env) + else + let passwd = + if ip = String.length base_passwd then "" + else + String.sub base_passwd (ip + 1) + (String.length base_passwd - ip - 1) + in + (passwd, env) + in + let command = + if cgi then String.sub str 0 iq + else if passwd = "" then base_file + else base_file ^ "_" ^ passwd + in + (command, base_file, passwd, env) + in + let (lang, env) = extract_assoc "lang" env in + let (from, env) = extract_assoc "from" env in +let (threshold_test, env) = extract_assoc "th" env in +do if threshold_test <> "" then RelationLink.threshold.val := int_of_string threshold_test else (); return + let (sleep, env) = + let (x, env) = extract_assoc "sleep" env in + (if x = "" then 0 else int_of_string x, env) + in + let base_env = read_base_env base_file in + let default_lang = + try List.assoc "default_lang" base_env with + [ Not_found -> default_lang.val ] + in + let lexicon = input_lexicon (if lang = "" then default_lang else lang) in + let real_wizard_passwd = + try List.assoc "wizard_passwd" base_env with + [ Not_found -> wizard_passwd.val ] + in + let real_friend_passwd = + try List.assoc "friend_passwd" base_env with + [ Not_found -> friend_passwd.val ] + in + let conf = + {wizard = passwd = real_wizard_passwd; + friend = passwd = real_friend_passwd; + cgi = cgi; + command = command; + lang = if lang = "" then default_lang else lang; + bname = base_file; + env = env; + senv = ""; + henv = + (if not cgi then [] + else if passwd = "" then [("b", base_file)] + else [("b", base_file ^ "_" ^ passwd)]) @ + (if lang = "" then [] else [("lang", lang)]) @ + (if from = "" then [] else [("from", from)]); + base_env = base_env; + request = request; + lexicon = lexicon; + today = + Djma tm.Unix.tm_mday (succ tm.Unix.tm_mon) (tm.Unix.tm_year + 1900); + today_d = tm.Unix.tm_mday; today_m = succ tm.Unix.tm_mon; + today_y = tm.Unix.tm_year + 1900; today_wd = tm.Unix.tm_wday} + in + if conf.bname = "" then propose_base conf + else + do start_with_base conf conf.bname; + if sleep > 0 then Unix.sleep sleep else (); + return () +; + +value chop_extension name = + loop (String.length name - 1) where rec loop i = + if i < 0 then name + else if name.[i] == '.' then String.sub name 0 i + else if name.[i] == '/' then name + else if name.[i] == '\\' then name + else loop (i - 1) +; + +value excluded from = + let efname = chop_extension Sys.argv.(0) ^ ".xcl" in + match try Some (open_in efname) with [ Sys_error _ -> None ] with + [ Some ic -> + loop () where rec loop () = + match try Some (input_line ic) with [ End_of_file -> None ] with + [ Some line -> + if from = line then do close_in ic; return True else loop () + | None -> do close_in ic; return False ] + | None -> False ] +; + +value content_image cgi t len = + do if not cgi then + do Wserver.wprint "HTTP/1.0 200 OK"; nl (); return () + else (); + Wserver.wprint "Content-type: image/%s" t; nl (); + Wserver.wprint "Content-length: %d" len; nl (); + nl (); + Wserver.wflush (); + return () +; + +value print_image cgi str t = + let fname = + let fname = + List.fold_right Filename.concat [Util.base_dir.val; "images"] str + in + if Sys.file_exists fname then fname else + List.fold_right Filename.concat [Util.lang_dir.val; "images"] str + in + match try Some (open_in_bin fname) with [ Sys_error _ -> None ] with + [ Some ic -> + do try + do content_image cgi t (in_channel_length ic); + try + let b = " " in + while True do + b.[0] := input_char ic; + Wserver.wprint "%c" b.[0]; + done + with [ End_of_file -> () ]; + return () + with e -> do close_in ic; return raise e; + close_in ic; + return () + | None -> () ] +; + +value image_request cgi env = + match (Util.p_getenv env "m", Util.p_getenv env "v") with + [ (Some "IM", Some fname) -> + do if Filename.is_implicit fname then + if Filename.check_suffix fname ".jpg" + || Filename.check_suffix fname ".JPG" then + print_image cgi fname "jpeg" + else if Filename.check_suffix fname ".gif" + || Filename.check_suffix fname ".GIF" then + print_image cgi fname "gif" + else () + else (); + return True + | _ -> False ] +; + +value check_auth request = + if auth_file.val = "" then None + else + match try Some (open_in auth_file.val) with [ Sys_error _ -> None ] with + [ Some ic -> + let auth = Wserver.extract_param "authorization: " '\r' request in + let auth = + if auth <> "" then + let i = String.length "Basic " in + Base64.decode (String.sub auth i (String.length auth - i)) + else auth + in + try + loop () where rec loop () = + if auth = input_line ic then do close_in ic; return None + else loop () + with + [ End_of_file -> do close_in ic; return Some auth ] + | _ -> None ] +; + +value connection cgi (addr, request) str = + let from = + match addr with + [ ADDR_UNIX x -> x + | ADDR_INET iaddr port -> + try (gethostbyaddr iaddr).h_name with _ -> string_of_inet_addr iaddr ] + in + if excluded from then refuse_log from cgi + else + let check = if cgi then None else check_auth request in + match check with + [ Some auth -> refuse_auth from auth + | _ -> + let accept = + if only_address.val = "" then True else only_address.val = from + in + if not accept then only_log from cgi + else + try + let iq = index '?' str in + let env = + let query_string = + if iq == String.length str then "" + else String.sub str (iq + 1) (String.length str - iq - 1) + in + Util.create_env query_string + in + if image_request cgi env then () + else + do if cgi && log_file.val = "" then () else log from request str; + connection_accepted cgi (addr, request) str env; + return () + with + [ Exit -> () ] ] +; + +value tmout = 120; + +value geneweb_server () = + let hostn = try Unix.gethostname () with _ -> "computer" in + let auto_call = + try let _ = Sys.getenv "WSERVER" in True with [ Not_found -> False ] + in + do if not auto_call then + do Printf.eprintf "GeneWeb %s - " Util.version; + Printf.eprintf "Copyright (c) INRIA 1998 +Possible addresses: + http://localhost:%d/base + http://127.0.0.1:%d/base + http://%s:%d/base +where \"base\" is the name of the data base +Type control C to stop the service +" + port_selected.val port_selected.val hostn port_selected.val; + flush Pervasives.stderr; + return () + else (); + try Unix.mkdir "cnt" 0o755 with + _ -> (); + return + Wserver.f port_selected.val tmout + (ifdef UNIX then max_clients.val else None) robot_xcl.val + (connection False) +; + +value geneweb_cgi str addr = + connection True (ADDR_UNIX addr, []) str +; + +value read_input len = + if len >= 0 then + let buff = String.create len in + do really_input Pervasives.stdin buff 0 len; return buff + else + let buff = ref "" in + do try + while True do + let l = input_line Pervasives.stdin in + do Printf.eprintf "POST: %s\n" l; flush Pervasives.stderr; return + buff.val := buff.val ^ l; + done + with + [ End_of_file -> () ]; + return buff.val +; + +value old_arg_parse_in_file lines = + match lines with + [ [x :: lines] -> + do Util.lang_dir.val := x; return + match lines with + [ [x :: lines] -> + do Util.base_dir.val := x; return + match lines with + [ [x :: _] -> cgi.val := x = "cgi" + | _ -> () ] + | _ -> () ] + | _ -> () ] +; + +value arg_parse_in_file fname speclist anonfun errmsg = + match try Some (open_in fname) with [ Sys_error _ -> None ] with + [ Some ic -> + let list = + let list = ref [] in + do try + while True do list.val := [input_line ic :: list.val]; done + with [ End_of_file -> () ]; + close_in ic; + return List.rev list.val + in + match list with + [ [x :: l] when String.length x > 0 && x.[0] == '-' -> + Argl.parse_list speclist anonfun errmsg list + | _ -> old_arg_parse_in_file list ] + | _ -> () ] +; + +module G = Grammar.Make (struct value lexer = Plexer.make (); end); +value robot_xcl_arg = G.Entry.create "robot_xcl arg"; +GEXTEND G + robot_xcl_arg: + [ [ cnt = INT; ","; sec = INT; EOI -> + (int_of_string cnt, int_of_string sec) ] ]; +END; + +value robot_exclude s = + try + robot_xcl.val := + Some (G.Entry.parse robot_xcl_arg (G.parsable (Stream.of_string s))) + with + [ Stdpp.Exc_located _ (Stream.Error _ | Token.Error _) -> + do Printf.eprintf "Bad use of option -robot_xcl\n"; + Printf.eprintf "Use option -help for usage.\n"; + flush Pervasives.stderr; + return exit 2 ] +; + +value main () = + let usage = "Usage: " ^ Sys.argv.(0) ^ " [options] where options are:" in + let speclist = + [("-hd", Arg.String (fun x -> Util.lang_dir.val := x), + " + Directory where the directory lang is installed."); + ("-bd", Arg.String (fun x -> Util.base_dir.val := x), + "dir> + Directory where the databases are installed."); + ("-cgi", Arg.Set cgi, + " + Force cgi mode."); + ("-p", Arg.Int (fun x -> port_selected.val := x), + " + Select a port number (default = " ^ string_of_int port_selected.val ^ + "); > 1024 for normal users."); + ("-wizard", Arg.String (fun x -> wizard_passwd.val := x), + " + Set a wizard passord: access to all dates and updating."); + ("-friend", Arg.String (fun x -> friend_passwd.val := x), + " + Set a friend password: access to all dates."); + ("-lang", Arg.String (fun x -> default_lang.val := x), + " + Set a default language (default: fr)."); + ("-only", Arg.String (fun x -> only_address.val := x), + "
      + Only inet address accepted."); + ("-auth", Arg.String (fun x -> auth_file.val := x), + " + Authorization file to restrict access. The file must hold lines + of the form \"user:password\"."); + ("-log", Arg.String (fun x -> log_file.val := x), + " + Redirect log trace to this file."); + ("-nolock", Arg.Set Lock.no_lock_flag, + " + Do not lock files before writing.") :: + ifdef UNIX then + [("-max_clients", + Arg.String + (fun x -> + try max_clients.val := Some (int_of_string x) with _ -> + raise (Arg.Bad "number expected after -max_clients")), + " + Max number of clients treated at the same time (default 4) (not cgi)."); + ("-robot_xcl", Arg.String robot_exclude, + ", + Exclude connections when more than requests in seconds.")] + else []] + in + let anonfun s = raise (Arg.Bad ("don't know what to do with " ^ s)) in + do arg_parse_in_file (chop_extension Sys.argv.(0) ^ ".arg") + speclist anonfun usage; + Argl.parse speclist anonfun usage; + return + let (query, cgi) = + try (Sys.getenv "QUERY_STRING", True) with + [ Not_found -> ("", cgi.val) ] + in + if cgi then + let is_post = + try Sys.getenv "REQUEST_METHOD" = "POST" with + [ Not_found -> False ] + in + let query = + if is_post then + let len = + try int_of_string (Sys.getenv "CONTENT_LENGTH") with + [ Not_found -> -1 ] + in + read_input len + else query + in + let addr = + try Sys.getenv "REMOTE_ADDR" with + [ Not_found -> "" ] + in + let script = + try Sys.getenv "SCRIPT_NAME" with + [ Not_found -> Sys.argv.(0) ] + in + let query = Filename.basename script ^ "?" ^ query in + geneweb_cgi query addr + else geneweb_server () +; + +ifdef UNIX then +value test_eacces_bind err fun_name = + if err = EACCES && fun_name = "bind" && port_selected.val <= 1024 then + do Printf.eprintf "\n\ +Error: invalid access to the port %d: users port number less than 1024 +are reserved to the system. Solution: become root or choose another port +number greater than 1024.\n" port_selected.val; + flush Pervasives.stderr; + return True + else False +else +value test_eacces_bind err fun_name = False; + +value print_exc exc = + match exc with + [ Unix_error EADDRINUSE "bind" _ -> + do Printf.eprintf "\n\ +Error: the port %d is already used by another GeneWeb daemon +or by another program. Solution: kill the other program or launch +GeneWeb with another port number (option -p)\n" port_selected.val; + flush Pervasives.stderr; + return () + | Unix_error err fun_name arg -> + if test_eacces_bind err fun_name then () + else + do prerr_string "\""; + prerr_string fun_name; + prerr_string "\" failed"; + if String.length arg > 0 then + do prerr_string " on \""; prerr_string arg; prerr_string "\""; + return () + else (); + prerr_string ": "; + prerr_endline (error_message err); + flush Pervasives.stderr; + return () + | _ -> try Printexc.print raise exc with _ -> () ] +; + +try main () with exc -> print_exc exc; diff --git a/src/gwu.ml b/src/gwu.ml new file mode 100644 index 0000000000..4f2d37e61b --- /dev/null +++ b/src/gwu.ml @@ -0,0 +1,605 @@ +(* $Id: gwu.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Def; +open Gutil; + +value soy y = if y == 0 then "-0" else string_of_int y; + +value print_date oc = + fun + [ Djma d m y -> Printf.fprintf oc "%d/%d/%s" d m (soy y) + | Dma m y -> Printf.fprintf oc "%d/%s" m (soy y) + | Da prec y -> + do match prec with + [ About -> Printf.fprintf oc "~" + | Maybe -> Printf.fprintf oc "?" + | Before -> Printf.fprintf oc "<" + | After -> Printf.fprintf oc ">" + | _ -> () ]; + Printf.fprintf oc "%s" (soy y); + match prec with + [ OrYear y -> Printf.fprintf oc "|%s" (soy y) + | _ -> () ]; + return () ] +; + +value print_date_option oc = + fun + [ Some d -> print_date oc d + | None -> () ] +; + +value buff = ref (String.create 80); +value store len x = + do if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + return succ len +; + +value get_buff len = String.sub buff.val 0 len; + +value starting_char = + fun + [ 'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' | '0'..'9' | '?' | ' ' -> True + | _ -> False ] +; + +value correct_string base is = + let s = sou base is in + loop 0 0 where rec loop i len = + if i == String.length s then get_buff len + else + if i == 0 && not (starting_char s.[0]) then + loop (i + 1) (store (store len '_') s.[0]) + else if s.[i] == ' ' then loop (i + 1) (store len '_') + else loop (i + 1) (store len s.[i]) +; + +value has_infos_not_dates base p = + p.first_names_aliases <> [] || p.surnames_aliases <> [] || + sou base p.public_name <> "" || p.nick_names <> [] || p.aliases <> [] || + p.titles <> [] || sou base p.occupation <> "" || + sou base p.birth_place <> "" || sou base p.baptism_place <> "" || + sou base p.death_place <> "" || sou base p.psources <> "" +; + +value has_infos base p = + has_infos_not_dates base p || p.birth <> Adef.codate_None || + p.baptism <> Adef.codate_None || p.death <> NotDead +; + +value print_first_name_alias oc base is = + Printf.fprintf oc " {%s}" (correct_string base is) +; + +value print_surname_alias oc base is = + Printf.fprintf oc " #salias %s" (correct_string base is) +; + +value print_nick_name oc base is = + Printf.fprintf oc " #nick %s" (correct_string base is) +; + +value print_alias oc base is = + Printf.fprintf oc " #alias %s" (correct_string base is) +; + +value print_photo oc base is = + if sou base is = "" then () + else Printf.fprintf oc " #photo %s" (correct_string base is) +; + +value print_burial oc base b = + match b with + [ Buried cod -> + do Printf.fprintf oc " #buri"; + match Adef.od_of_codate cod with + [ Some d -> + do Printf.fprintf oc " "; + print_date oc d; + return () + | _ -> () ]; + return () + | Cremated cod -> + do Printf.fprintf oc " #crem"; + match Adef.od_of_codate cod with + [ Some d -> + do Printf.fprintf oc " "; + print_date oc d; + return () + | _ -> () ]; + return () + | UnknownBurial -> () ] +; + +value print_burial_place oc base is = + Printf.fprintf oc " #rp %s" (correct_string base is) +; + +value print_title oc base t = + let t_date_start = Adef.od_of_codate t.t_date_start in + let t_date_end = Adef.od_of_codate t.t_date_end in + do Printf.fprintf oc " ["; + match t.t_name with + [ Tmain -> Printf.fprintf oc "*" + | Tname s -> Printf.fprintf oc "%s" (correct_string base s) + | Tnone -> () ]; + Printf.fprintf oc ":"; + Printf.fprintf oc "%s" (correct_string base t.t_title); + Printf.fprintf oc ":"; + Printf.fprintf oc "%s" (correct_string base t.t_place); + if t.t_nth <> 0 then Printf.fprintf oc ":" + else + match (t_date_start, t_date_end) with + [ (Some _, _) | (_, Some _) -> Printf.fprintf oc ":" + | _ -> () ]; + print_date_option oc t_date_start; + if t.t_nth <> 0 then Printf.fprintf oc ":" + else + match t_date_end with + [ Some _ -> Printf.fprintf oc ":" + | _ -> () ]; + print_date_option oc t_date_end; + if t.t_nth <> 0 then Printf.fprintf oc ":%d" t.t_nth else (); + Printf.fprintf oc "]"; + return () +; + +value print_infos oc base is_child print_sources p = + do List.iter (print_first_name_alias oc base) p.first_names_aliases; + List.iter (print_surname_alias oc base) p.surnames_aliases; + match p.public_name with + [ s when sou base s <> "" -> + Printf.fprintf oc " (%s)" (correct_string base s) + | _ -> () ]; + print_photo oc base p.photo; + List.iter (print_nick_name oc base) p.nick_names; + List.iter (print_alias oc base) p.aliases; + List.iter (print_title oc base) p.titles; + match p.access with + [ IfTitles -> () + | Public -> Printf.fprintf oc " #apubl" + | Private -> Printf.fprintf oc " #apriv" ]; + match p.occupation with + [ s when sou base s <> "" -> + Printf.fprintf oc " #occu %s" (correct_string base s) + | _ -> () ]; + if print_sources then + match p.psources with + [ s when sou base s <> "" -> + Printf.fprintf oc " #src %s" (correct_string base s) + | _ -> () ] + else (); + match Adef.od_of_codate p.birth with + [ Some d -> + do Printf.fprintf oc " "; + print_date oc d; + return () + | _ -> + if p.baptism <> Adef.codate_None then () + else + match p.death with + [ Death _ _ | DeadYoung | DeadDontKnowWhen -> Printf.fprintf oc " 0" + | DontKnowIfDead + when not is_child && not (has_infos_not_dates base p) && + sou base p.first_name <> "?" && sou base p.surname <> "?" -> + Printf.fprintf oc " 0" + | _ -> () ] ]; + if sou base p.birth_place <> "" then + Printf.fprintf oc " #bp %s" (correct_string base p.birth_place) + else (); + match Adef.od_of_codate p.baptism with + [ Some d -> + do Printf.fprintf oc " !"; + print_date oc d; + return () + | _ -> () ]; + if sou base p.baptism_place <> "" then + Printf.fprintf oc " #pp %s" (correct_string base p.baptism_place) + else (); + match p.death with + [ Death dr d -> + do Printf.fprintf oc " "; + match dr with + [ Killed -> Printf.fprintf oc "k" + | Murdered -> Printf.fprintf oc "m" + | Executed -> Printf.fprintf oc "e" + | Disappeared -> Printf.fprintf oc "s" + | _ -> () ]; + print_date oc (Adef.date_of_cdate d); + return () + | DeadYoung -> Printf.fprintf oc " mj" + | DeadDontKnowWhen -> Printf.fprintf oc " 0" + | DontKnowIfDead -> + match (Adef.od_of_codate p.birth, Adef.od_of_codate p.baptism) with + [ (Some _, _) | (_, Some _) -> Printf.fprintf oc " ?" + | _ -> () ] + | NotDead -> () ]; + if sou base p.death_place <> "" then + Printf.fprintf oc " #dp %s" (correct_string base p.death_place) + else (); + print_burial oc base p.burial; + if sou base p.burial_place <> "" then + print_burial_place oc base p.burial_place + else (); + return () +; + +value print_parent oc base ifaml fam_sel fam ip = + let p = poi base ip in + let a = aoi base ip in + do Printf.fprintf oc "%s %s%s" (correct_string base p.surname) + (correct_string base p.first_name) + (if p.occ == 0 || sou base p.first_name = "?" + || sou base p.surname = "?" then "" + else "." ^ string_of_int p.occ); + return + let has_printed_parents = + match a.parents with + [ Some ifam -> fam_sel ifam + | None -> False ] + in + let first_parent_definition = + loop ifaml where rec loop = + fun + [ [ifam1 :: ifaml1] -> + let cpl = coi base ifam1 in + if cpl.father == ip || cpl.mother == ip then fam.fam_index == ifam1 + else loop ifaml1 + | [] -> assert False ] + in + let pr = not has_printed_parents && first_parent_definition in + if pr (* && sou base p.first_name <> "?" *) then + if has_infos base p then print_infos oc base False True p + else if sou base p.first_name <> "?" && sou base p.surname <> "?" then + Printf.fprintf oc " 0" + else () + else () +; + +value print_child oc base fam_surname print_sources ip = + let p = poi base ip in + do Printf.fprintf oc "-"; + match p.sexe with + [ Masculin -> Printf.fprintf oc " h" + | Feminin -> Printf.fprintf oc " f" + | _ -> () ]; + Printf.fprintf oc " %s" (correct_string base p.first_name); + if p.occ == 0 || sou base p.first_name = "?" || sou base p.surname = "?" + then () + else Printf.fprintf oc ".%d" p.occ; + if p.surname <> fam_surname then + Printf.fprintf oc " %s" (correct_string base p.surname) + else (); + print_infos oc base True print_sources p; + Printf.fprintf oc "\n"; + return () +; + +value bogus_person base ip = + let p = poi base ip in + sou base p.first_name = "?" && sou base p.surname = "?" +; + +value common_children_sources base children = + if Array.length children <= 1 then None + else + loop 1 (poi base children.(0)).psources where rec loop i src = + if i == Array.length children then + let s = sou base src in + if s = "" then None else Some src + else + let p = poi base children.(i) in + if p.psources == src then loop (i + 1) src else None +; + +value array_forall f a = + loop 0 where rec loop i = + if i == Array.length a then True + else if f a.(i) then loop (i + 1) + else False +; + +value empty_family base fam = + let cpl = coi base fam.fam_index in + bogus_person base cpl.father && bogus_person base cpl.mother && + array_forall (bogus_person base) fam.children +; + +value print_family oc base ifaml (per_sel, fam_sel) fam_done ifam = + let fam = foi base ifam in + let cpl = coi base ifam in + do Printf.fprintf oc "fam "; + print_parent oc base ifaml fam_sel fam cpl.father; + Printf.fprintf oc " +"; + print_date_option oc (Adef.od_of_codate fam.marriage); + match sou base fam.marriage_place with + [ "" -> () + | s -> + Printf.fprintf oc " #mp %s" + (correct_string base fam.marriage_place) ]; + match fam.divorce with + [ NotDivorced -> () + | Divorced d -> + let d = Adef.od_of_codate d in + do Printf.fprintf oc " -"; print_date_option oc d; return () ]; + Printf.fprintf oc " "; + print_parent oc base ifaml fam_sel fam cpl.mother; + Printf.fprintf oc "\n"; + match sou base fam.fsources with + [ "" -> () + | s -> Printf.fprintf oc "src %s\n" (correct_string base fam.fsources) ]; + match fam.comment with + [ txt when sou base txt <> "" -> + Printf.fprintf oc "comm %s\n" (sou base txt) + | _ -> () ]; + let print_sources = + match common_children_sources base fam.children with + [ Some s -> + do Printf.fprintf oc "csrc %s\n" (correct_string base s); return + False + | _ -> True ] + in + match Array.length fam.children with + [ 0 -> () + | _ -> + let fam_surname = (poi base cpl.father).surname in + do Printf.fprintf oc "beg\n"; + Array.iter + (fun ip -> + if per_sel ip then + print_child oc base fam_surname print_sources ip + else ()) + fam.children; + Printf.fprintf oc "end\n"; + return () ]; + fam_done.(Adef.int_of_ifam fam.fam_index) := True; + return () +; + +value get_persons_with_notes base ifam list = + let fam = foi base ifam in + let cpl = coi base ifam in + let father = poi base cpl.father in + let mother = poi base cpl.mother in + let list = + match (sou base father.notes, (aoi base cpl.father).parents) with + [ ("", _) | (_, Some _) -> list + | _ -> [cpl.father :: list] ] + in + let list = + match (sou base mother.notes, (aoi base cpl.mother).parents) with + [ ("", _) | (_, Some _) -> list + | _ -> [cpl.mother :: list] ] + in + List.fold_right + (fun ip list -> + let p = poi base ip in + match sou base p.notes with + [ "" -> list + | _ -> [ip :: list] ]) + (Array.to_list fam.children) list +; + +value print_notes_for_person oc base ip = + let p = poi base ip in + do Printf.fprintf oc "\n"; + Printf.fprintf oc "notes %s %s%s\n" + (correct_string base p.surname) + (correct_string base p.first_name) + (if p.occ == 0 then "" else "." ^ string_of_int p.occ); + Printf.fprintf oc "beg\n"; + Printf.fprintf oc "%s\n" (sou base p.notes); + Printf.fprintf oc "end notes\n"; + return () +; + +value print_notes oc base ifaml per_sel = + let ipl = List.fold_right (get_persons_with_notes base) ifaml [] in + let ipl = + List.fold_right + (fun ip ipl -> if List.memq ip ipl then ipl else [ip :: ipl]) + ipl [] + in + List.iter + (fun ip -> if per_sel ip then print_notes_for_person oc base ip else ()) + ipl +; + +value rec merge_families ifaml1f ifaml2f = + match (ifaml1f, ifaml2f) with + [ ([ifam1 :: ifaml1], [ifam2 :: ifaml2]) -> + let m1 = List.memq ifam1 ifaml2 in + let m2 = List.memq ifam2 ifaml1 in + if m1 && m2 then merge_families ifaml1 ifaml2 + else if m1 then + [ifam2 :: merge_families ifaml1f ifaml2] + else if m2 then + [ifam1 :: merge_families ifaml1 ifaml2f] + else if ifam1 == ifam2 then [ifam1 :: merge_families ifaml1 ifaml2] + else [ifam1; ifam2 :: merge_families ifaml1 ifaml2] + | (ifaml1, []) -> ifaml1 + | ([], ifaml2) -> ifaml2 ] +; + +value rec filter f = + fun + [ [x :: l] -> if f x then [x :: filter f l] else filter f l + | [] -> [] ] +; + +value connected_families base fam_sel fam = + loop [fam.fam_index] [] [(coi base fam.fam_index).father] + where rec loop ifaml ipl_scanned = + fun + [ [ip :: ipl] -> + if List.memq ip ipl_scanned then loop ifaml ipl_scanned ipl + else + let p = poi base ip in + let ifaml1 = Array.to_list p.family in + let ifaml1 = filter fam_sel ifaml1 in + let ifaml = merge_families ifaml ifaml1 in + let ipl = + List.fold_right + (fun ifam ipl -> + let cpl = coi base ifam in + [cpl.father; cpl.mother :: ipl]) + ifaml1 ipl + in + loop ifaml [ip :: ipl_scanned] ipl + | [] -> ifaml ] +; + +value find_person base p1 po p2 = + try Gutil.person_ht_find_unique base p1 p2 po with + [ Not_found -> + do Printf.eprintf "Not found: %s%s %s\n" + p1 (if po == 0 then "" else " " ^ string_of_int po) p2; + flush stderr; + return exit 2 ] +; + +value gwu base out_dir src_oc_list anc = + let anc = + match anc with + [ Some (p1, po, p2) -> Some (find_person base p1 po p2) + | None -> None ] + in + let ((per_sel, fam_sel) as sel) = Select.functions base anc None in + let fam_done = Array.create (base.families.len) False in + for i = 0 to base.families.len - 1 do + let fam = base.families.get i in + if is_deleted_family fam then () + else + do if fam_done.(i) then () + else if fam_sel fam.fam_index then + let ifaml = connected_families base fam_sel fam in + let (oc, first) = + try List.assoc fam.origin_file src_oc_list.val with + [ Not_found -> + let fname = sou base fam.origin_file in + let oc = + if out_dir = "" then stdout + else if fname = "" then stdout + else open_out (Filename.concat out_dir fname) + in + let x = (oc, ref True) in + do src_oc_list.val := + [(fam.origin_file, x) :: src_oc_list.val]; + return x ] + in + let ifaml = + List.fold_right + (fun ifam ifaml -> + if empty_family base (foi base ifam) then ifaml + else [ifam :: ifaml]) + ifaml [] + in + if ifaml <> [] then + do if not first.val then Printf.fprintf oc "\n" else (); + first.val := False; + List.iter (print_family oc base ifaml sel fam_done) ifaml; + print_notes oc base ifaml per_sel; + return () + else () + else (); + return (); + done +; + +value in_file = ref ""; +value out_dir = ref ""; +value anc_1st = ref ""; +value anc_occ = ref 0; +value anc_2nd = ref ""; + +type arg_state = [ ASnone | ASwaitAncOcc | ASwaitAncSurn ]; +value arg_state = ref ASnone; + +value speclist = + [("-odir", Arg.String (fun s -> out_dir.val := s), + " create files in this directories (else all on stdout)"); + ("-a", + Arg.String + (fun s -> do anc_1st.val := s; return arg_state.val := ASwaitAncOcc), + "\"<1st_name>\" [num] \"\": select ancestors of...")] +; + +value anon_fun s = + match arg_state.val with + [ ASnone -> in_file.val := s + | ASwaitAncOcc -> + try + do anc_occ.val := int_of_string s; return + arg_state.val := ASwaitAncSurn + with + [ Failure _ -> + do anc_occ.val := 0; anc_2nd.val := s; return + arg_state.val := ASnone ] + | ASwaitAncSurn -> + do anc_2nd.val := s; return arg_state.val := ASnone ] +; + +value errmsg = "Usage: " ^ Sys.argv.(0) ^ " [options] +Options are:"; + +value main () = + do Argl.parse speclist anon_fun errmsg; + if in_file.val = "" then + do Printf.eprintf "Missing base\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 + else (); + return + let anc = + if anc_1st.val <> "" then + if anc_2nd.val = "" then + do Printf.eprintf "Misused option -a\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return exit 2 + else Some (anc_1st.val, anc_occ.val, anc_2nd.val) + else None + in + let base = Iobase.input in_file.val in + let src_oc_list = ref [] in + let _ = base.persons.array () in + let _ = base.ascends.array () in + let _ = base.families.array () in + let _ = base.couples.array () in + let _ = base.strings.array () in + let oc_list = ref [] in +(* + for i = 0 to base.families.len - 1 do + let fam = base.families.get i in + if is_deleted_family fam then () + else + let first = ref True in + try let _ = List.assoc fam.origin_file src_oc_list.val in () with + [ Not_found -> + let oc_f = + if out_dir.val = "" then (stdout, first) + else if sou base fam.origin_file = "" then + (stdout, first) + else + (open_out + (Filename.concat out_dir.val (sou base fam.origin_file)), + ref True) + in + src_oc_list.val := + [(fam.origin_file, oc_f) :: src_oc_list.val] ]; + done; +*) + do gwu base out_dir.val src_oc_list anc; + List.iter + (fun (src, (oc, _)) -> + do flush oc; return + if oc != stdout then close_out oc else ()) + src_oc_list.val; + return () +; + +Printexc.catch main (); diff --git a/src/i18n_check.ml b/src/i18n_check.ml new file mode 100644 index 0000000000..5d68e91920 --- /dev/null +++ b/src/i18n_check.ml @@ -0,0 +1,31 @@ +(* $Id: i18n_check.ml,v 1.1 1998-09-01 14:32:12 ddr Exp $ *) + +value usage () = + do Printf.eprintf "Usage: i18n_check lang lexicon\n"; + flush stderr; + exit 2; + return () +; + +value main () = + if Array.length Sys.argv <> 3 then usage () + else + let lang = Sys.argv.(1) in + let file = Sys.argv.(2) in + let ic = open_in_bin file in + try + while True do + let line_ref = input_line ic in + loop (input_line ic) where rec loop line = + if line = "" then () + else + do if String.sub line 0 4 = lang ^ ": " then + Printf.printf "%s\n" + (String.sub line_ref 4 (String.length line_ref - 4)) + else (); + return loop (input_line ic); + done + with [ End_of_file -> () ] +; + +Printexc.catch main (); diff --git a/src/iobase.ml b/src/iobase.ml new file mode 100644 index 0000000000..6dac993cae --- /dev/null +++ b/src/iobase.ml @@ -0,0 +1,703 @@ +(* $Id: iobase.ml,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +open Def; +open Gutil; + +value magic_gwb = "GnWb001p"; + +value output_value_header_size = 20; +value output_value_no_sharing oc v = + Marshal.to_channel oc v [Marshal.No_sharing] +; + +value array_header_size arr = + if Array.length arr < 8 then 1 else 5 +; + +value output_array_access oc arr pos = + let rec loop pos i = + if i == Array.length arr then pos + else + do output_binary_int oc pos; return + loop (pos + Iovalue.size arr.(i)) (i + 1) + in + loop (pos + output_value_header_size + array_header_size arr) 0 +; + +value rec list_remove_assoc x = + fun + [ [(x1, y1) :: l] -> + if x = x1 then l else [(x1, y1) :: list_remove_assoc x l] + | [] -> [] ] +; + +value array_memq x a = + loop 0 where rec loop i = + if i == Array.length a then False + else if x == a.(i) then True + else loop (i + 1) +; + +(* Search index of a given string in file .gw2 *) + +value int_size = 4; + +value string_piece s = + let s = String.escaped s in + if String.length s > 20 then + String.sub s 0 10 ^ " ... " ^ String.sub s (String.length s - 10) 10 + else s +; + +value rec list_right_assoc s = + fun + [ [(i1, s1) :: l] -> if s = s1 then i1 else list_right_assoc s l + | [] -> raise Not_found ] +; + +value index_of_string strings ic start_pos hash_len string_patches s = + try Adef.istr_of_int (list_right_assoc s string_patches.val) with + [ Not_found -> + let ia = Hashtbl.hash s mod hash_len in + do seek_in ic (start_pos + ia * int_size); return + let i1 = input_binary_int ic in + loop i1 where rec loop i = + if i == -1 then raise Not_found + else + if strings.get i = s then Adef.istr_of_int i + else + do seek_in ic (start_pos + (hash_len + i) * int_size); + return loop (input_binary_int ic) ] +; + +(* Search index of a given surname or given first name in file .gw2 *) + +value compare_names = Gutil.alphabetique; +value compare_istr = ref (fun []); +value set_compare_istr base = + compare_istr.val := + fun is1 is2 -> + if is1 == is2 then 0 + else + compare_names (base.strings.get (Adef.int_of_istr is1)) + (base.strings.get (Adef.int_of_istr is2)) +; +module IstrTree = + Btree.Make + (struct type t = istr; value compare x y = compare_istr.val x y; end) +; + +type first_name_or_surname_index = IstrTree.t (list iper); + +value fsname_btree (ic2, start_pos, proj, person_patches, tree_name) = + let btr = ref None in + fun () -> + match btr.val with + [ Some bt -> bt + | None -> + do seek_in ic2 start_pos; return + let bt : first_name_or_surname_index = input_value ic2 in + let bt = + List.fold_left + (fun bt (i, p) -> + let istr = proj p in + let ipera = + try IstrTree.find istr bt with + [ Not_found -> [] ] + in + if List.memq p.cle_index ipera then bt + else + IstrTree.add istr [ p.cle_index :: ipera] bt) + bt person_patches.val + in + do btr.val := Some bt; return bt ] +; + +value persons_of_first_name_or_surname strings params = + let bt = fsname_btree params in + let find istr = try IstrTree.find istr (bt ()) with [ Not_found -> [] ] in + let cursor str = + IstrTree.key_after + (fun key -> compare_names str (strings.get (Adef.int_of_istr key))) + (bt ()) + in + let next key = IstrTree.next key (bt ()) in + {find = find; cursor = cursor; next = next} +; + +(* Search index for a given name in file .inx *) + +type name_index_data = array (array iper); + +value persons_of_name bname patches = + let t = ref None in + fun s -> + let s = Name.crush_lower s in + let a = + match t.val with + [ Some a -> a + | None -> + let ic_inx = open_in_bin (Filename.concat bname "inx") in + do seek_in ic_inx int_size; return + let a = (input_value ic_inx : name_index_data) in + do close_in ic_inx; t.val := Some a; return a ] + in + let i = Hashtbl.hash s in + match patches.val with + [ [] -> Array.to_list a.(i mod (Array.length a)) + | pl -> + let l = try List.assoc i patches.val with [ Not_found -> [] ] in + l @ Array.to_list a.(i mod (Array.length a)) ] +; + +type strings_of_fsname = array (array istr); + +value strings_of_fsname bname strings person_patches = + let t = ref None in + fun s -> + let s = Name.crush_lower s in + let a = + match t.val with + [ Some a -> a + | None -> + let ic_inx = open_in_bin (Filename.concat bname "inx") in + let pos = input_binary_int ic_inx in + do seek_in ic_inx pos; return + let a = (input_value ic_inx : strings_of_fsname) in + do close_in ic_inx; t.val := Some a; return a ] + in + let i = Hashtbl.hash s in + let r = a.(i mod (Array.length a)) in + match person_patches.val with + [ [] -> Array.to_list r + | _ -> + let l = + List.fold_left + (fun l (_, p) -> + let l = + if not (List.memq p.first_name l) then + let s1 = strings.get (Adef.int_of_istr p.first_name) in + if s = Name.crush_lower s1 then [p.first_name :: l] else l + else l + in + let l = + if not (List.memq p.surname l) then + let s1 = strings.get (Adef.int_of_istr p.surname) in + if s = Name.crush_lower s1 then [p.surname :: l] else l + else l + in l) + (Array.to_list r) person_patches.val + in + l ] +; + +value lock_file bname = + let bname = + if Filename.check_suffix bname ".gwb" then + Filename.chop_suffix bname ".gwb" + else bname + in + bname ^ ".lck" +; + +(* Input *) + +value rec apply_patches tab = + fun + [ [] -> tab + | [(i, v) :: l] -> + let tab = apply_patches tab l in + let tab = + if i >= Array.length tab then + let new_tab = Array.create (i + 1) (Obj.magic 0) in + do Array.blit tab 0 new_tab 0 (Array.length tab); return + new_tab + else tab + in + do tab.(i) := v; return tab ] +; + +value rec patch_len len = + fun + [ [] -> len + | [(i, _) :: l] -> patch_len (max len (i + 1)) l ] +; + +type patches = + { p_person : ref (list (int * base_person)); + p_ascend : ref (list (int * base_ascend)); + p_family : ref (list (int * base_family)); + p_couple : ref (list (int * base_couple)); + p_string : ref (list (int * string)); + p_name : ref (list (int * list iper)) } +; + +value check_magic = + let b = String.create (String.length magic_gwb) in + fun ic -> + do really_input ic b 0 (String.length b); return + if b <> magic_gwb then + if String.sub magic_gwb 0 4 = String.sub b 0 4 then + failwith "this is a GeneWeb base, but not compatible" + else + failwith "this is not a GeneWeb base, or it is a very old version" + else () +; + +value make_cache ic ic_acc shift array_pos patches len name = + let tab = ref None in + let array () = + match tab.val with + [ Some x -> x + | None -> +do ifdef UNIX then do Printf.eprintf "*** read %s\n" name; flush Pervasives.stderr; return () else (); return + do seek_in ic array_pos; return + let t = apply_patches (input_value ic) patches.val in + do tab.val := Some t; return t ] + in + let r = + {array = array; get = fun []; len = patch_len len patches.val} + in + let gen_get i = + if tab.val <> None then (r.array ()).(i) + else + try List.assoc i patches.val with + [ Not_found -> + if i < 0 || i >= len then + failwith ("access " ^ name ^ " out of bounds") + else + do seek_in ic_acc (shift + Iovalue.sizeof_long * i); return + let pos = input_binary_int ic_acc in + do seek_in ic pos; return + Iovalue.input ic ] + in + do r.get := gen_get; return r +; + +value make_cached ic ic_acc shift array_pos patches len cache_htab name = + let tab = ref None in + let array () = + match tab.val with + [ Some x -> x + | None -> +do ifdef UNIX then do Printf.eprintf "*** read %s\n" name; flush Pervasives.stderr; return () else (); return + do seek_in ic array_pos; return + let t = apply_patches (input_value ic) patches.val in + do tab.val := Some t; return t ] + in + let r = + {array = array; get = fun []; len = patch_len len patches.val} + in + let gen_get i = + if tab.val <> None then (r.array ()).(i) + else + try Hashtbl.find cache_htab i with + [ Not_found -> + let r = + try List.assoc i patches.val with + [ Not_found -> + if i < 0 || i >= len then + failwith ("access " ^ name ^ " out of bounds") + else + do seek_in ic_acc (shift + Iovalue.sizeof_long * i); return + let pos = input_binary_int ic_acc in + do seek_in ic pos; return + Iovalue.input ic ] + in + do Hashtbl.add cache_htab i r; return r ] + in + do r.get := gen_get; return r +; + +value input bname = + let bname = + if Filename.check_suffix bname ".gwb" then bname + else bname ^ ".gwb" + in + let patches = + match + try Some (open_in_bin (Filename.concat bname "gw9")) with _ -> None + with + [ Some ic -> + let p = input_value ic in + do close_in ic; return p + | None -> + {p_person = ref []; p_ascend = ref []; p_family = ref []; + p_couple = ref []; p_string = ref []; p_name = ref []} ] + in + let ic = open_in_bin (Filename.concat bname "gwb") in + do check_magic ic; return + let ic_acc = open_in_bin (Filename.concat bname "acc") in + let ic2 = open_in_bin (Filename.concat bname "gw2") in + let persons_len = input_binary_int ic in + let ascends_len = input_binary_int ic in + let families_len = input_binary_int ic in + let couples_len = input_binary_int ic in + let strings_len = input_binary_int ic in + let persons_array_pos = input_binary_int ic in + let ascends_array_pos = input_binary_int ic in + let families_array_pos = input_binary_int ic in + let couples_array_pos = input_binary_int ic in + let strings_array_pos = input_binary_int ic in + let ic2_string_start_pos = 3 * int_size in + let ic2_string_hash_len = input_binary_int ic2 in + let ic2_surname_start_pos = input_binary_int ic2 in + let ic2_first_name_start_pos = input_binary_int ic2 in + let shift = 0 in + let persons = + make_cache ic ic_acc shift persons_array_pos patches.p_person persons_len + "persons" + in + let shift = shift + persons_len * Iovalue.sizeof_long in + let ascends = + make_cache ic ic_acc shift ascends_array_pos patches.p_ascend ascends_len + "ascends" + in + let shift = shift + ascends_len * Iovalue.sizeof_long in + let families = + make_cache ic ic_acc shift families_array_pos patches.p_family + families_len "families" + in + let shift = shift + families_len * Iovalue.sizeof_long in + let couples = + make_cache ic ic_acc shift couples_array_pos patches.p_couple couples_len + "couples" + in + let shift = shift + couples_len * Iovalue.sizeof_long in + let strings_cache = Hashtbl.create 101 in + let strings = + make_cached ic ic_acc shift strings_array_pos patches.p_string strings_len + strings_cache "strings" + in + let cleanup () = + do close_in ic; close_in ic_acc; close_in ic2; return () + in + let commit_patches () = + let fname = Filename.concat bname "gw9" in + do try Sys.remove (fname ^ "~") with _ -> (); + try Sys.rename fname (fname ^ "~") with _ -> (); + return + let oc9 = open_out_bin fname in + do output_value_no_sharing oc9 patches; + close_out oc9; + return () + in + let patch_person i p = + let i = Adef.int_of_iper i in + do persons.len := max persons.len (i + 1); + patches.p_person.val := + [(i, p) :: list_remove_assoc i patches.p_person.val]; + return () + in + let patch_ascend i a = + let i = Adef.int_of_iper i in + do ascends.len := max ascends.len (i + 1); + patches.p_ascend.val := + [(i, a) :: list_remove_assoc i patches.p_ascend.val]; + return () + in + let patch_family i f = + let i = Adef.int_of_ifam i in + do families.len := max families.len (i + 1); + patches.p_family.val := + [(i, f) :: list_remove_assoc i patches.p_family.val]; + return () + in + let patch_couple i c = + let i = Adef.int_of_ifam i in + do couples.len := max couples.len (i + 1); + patches.p_couple.val := + [(i, c) :: list_remove_assoc i patches.p_couple.val]; + return () + in + let patch_string i s = + let i = Adef.int_of_istr i in + do strings.len := max strings.len (i + 1); + patches.p_string.val := + [(i, s) :: list_remove_assoc i patches.p_string.val]; + Hashtbl.add strings_cache i s; + return () + in + let patch_name s ip = + let s = Name.crush_lower s in + let i = Hashtbl.hash s in + let (ipl, name_patches_rest) = + find patches.p_name.val where rec find = + fun + [ [] -> ([], []) + | [(i1, ipl1) :: l] -> + if i = i1 then (ipl1, l) + else let (ipl, l) = find l in (ipl, [(i1, ipl1) :: l]) ] + in + if List.memq ip ipl then () + else patches.p_name.val := [(i, [ip :: ipl]) :: name_patches_rest] + in + let base = + {persons = persons; + ascends = ascends; + families = families; + couples = couples; + strings = strings; + persons_of_name = persons_of_name bname patches.p_name; + strings_of_fsname = strings_of_fsname bname strings patches.p_person; + has_family_patches = + patches.p_family.val <> [] || patches.p_couple.val <> []; + index_of_string = + index_of_string strings ic2 ic2_string_start_pos ic2_string_hash_len + patches.p_string; + persons_of_surname = + persons_of_first_name_or_surname strings + (ic2, ic2_surname_start_pos, fun p -> p.surname, patches.p_person, + "surname"); + persons_of_first_name = + persons_of_first_name_or_surname strings + (ic2, ic2_first_name_start_pos, fun p -> p.first_name, + patches.p_person, "first_name"); + patch_person = patch_person; + patch_ascend = patch_ascend; + patch_family = patch_family; + patch_couple = patch_couple; + patch_string = patch_string; + patch_name = patch_name; + commit_patches = commit_patches; cleanup = cleanup} + in + do set_compare_istr base; return base +; + +(* Output *) + +value is_prime a = + loop 2 where rec loop b = + if a / b < b then True + else if a mod b == 0 then False + else loop (b + 1) +; + +value rec prime_after n = + if is_prime n then n else prime_after (n + 1) +; + +value output_strings_hash oc2 base = + let strings_array = base.strings.array () in + let taba = + Array.create (prime_after (max 2 (10 * Array.length strings_array))) (-1) + in + let tabl = Array.create (Array.length strings_array) (-1) in + do for i = 0 to Array.length strings_array - 1 do + let ia = Hashtbl.hash (strings_array.(i)) mod (Array.length taba) in + do tabl.(i) := taba.(ia); + taba.(ia) := i; + return (); + done; + return + do output_binary_int oc2 (Array.length taba); + output_binary_int oc2 0; + output_binary_int oc2 0; + for i = 0 to Array.length taba - 1 do + output_binary_int oc2 taba.(i); + done; + for i = 0 to Array.length tabl - 1 do + output_binary_int oc2 tabl.(i); + done; + return () +; + +value create_first_name_or_surname_index base proj = + let bt = ref IstrTree.empty in + do set_compare_istr base; + for i = 0 to base.persons.len - 1 do + let p = base.persons.get i in + let a = + try IstrTree.find (proj p) bt.val with + [ Not_found -> [] ] + in + bt.val := + IstrTree.add (proj p) [ p.cle_index :: a] bt.val; + done; + return bt.val +; + +value output_surname_index oc2 base = + let bt = create_first_name_or_surname_index base (fun p -> p.surname) in + output_value_no_sharing oc2 (bt : first_name_or_surname_index) +; + +value output_first_name_index oc2 base = + let bt = create_first_name_or_surname_index base (fun p -> p.first_name) in + output_value_no_sharing oc2 (bt : first_name_or_surname_index) +; + +value table_size = 0x3fff; +value make_name_index base = + let t = Array.create table_size [| |] in + let a = base.persons.array () in + let add_name key valu = + let i = Hashtbl.hash (Name.crush (Name.abbrev key)) mod (Array.length t) in + if array_memq valu t.(i) then () + else t.(i) := Array.append [| valu |] t.(i) + in + let rec add_names ip = + fun + [ [] -> () + | [n :: nl] -> do add_name n ip; return add_names ip nl ] + in + do for i = 0 to Array.length a - 1 do + let p = base.persons.get i in + let first_name = sou base p.first_name in + let surname = sou base p.surname in + if first_name <> "?" && surname <> "?" then + let names = + [Name.lower (first_name ^ " " ^ surname) :: + person_misc_names base p] + in + add_names p.cle_index names + else (); + done; + return t +; + +value create_name_index oc_inx base = + let ni = make_name_index base in + output_value_no_sharing oc_inx (ni : name_index_data) +; + +value add_name t key valu = + let i = Hashtbl.hash (Name.crush_lower key) mod (Array.length t) in + if array_memq valu t.(i) then () + else t.(i) := Array.append [| valu |] t.(i) +; + +value make_strings_of_fsname base = + let t = Array.create table_size [||] in + let a = base.persons.array () in + do for i = 0 to Array.length a - 1 do + let p = base.persons.get i in + let first_name = sou base p.first_name in + let surname = sou base p.surname in + do if first_name <> "?" then add_name t first_name p.first_name + else (); + if surname <> "?" then add_name t surname p.surname + else (); + return (); + done; + return t +; + +value create_strings_of_fsname oc_inx base = + let t = make_strings_of_fsname base in + output_value_no_sharing oc_inx (t : strings_of_fsname) +; + +value count_error computed found = + do Printf.eprintf "Count error. Computed %d. Found %d.\n" computed found; + flush stderr; + return exit 2 +; + +value output bname base = + let bname = + if Filename.check_suffix bname ".gwb" then bname + else bname ^ ".gwb" + in + do try Unix.mkdir bname 0o755 with _ -> (); return + let tmp_fname = Filename.concat bname "1wb" in + let tmp_fname_acc = Filename.concat bname "1cc" in + let tmp_fname_inx = Filename.concat bname "1nx" in + let tmp_fname_gw2 = Filename.concat bname "1w2" in + let _ = base.persons.array () in + let _ = base.ascends.array () in + let _ = base.families.array () in + let _ = base.couples.array () in + let _ = base.strings.array () in + do base.cleanup (); return + let oc = open_out_bin tmp_fname in + let oc_acc = open_out_bin tmp_fname_acc in + let oc_inx = open_out_bin tmp_fname_inx in + let oc2 = open_out_bin tmp_fname_gw2 in + let output_array arr = + let bpos = pos_out oc in + do output_value_no_sharing oc arr; return + let epos = output_array_access oc_acc arr bpos in + if epos <> pos_out oc then count_error epos (pos_out oc) else () + in + try + do output_string oc magic_gwb; + output_binary_int oc base.persons.len; + output_binary_int oc base.ascends.len; + output_binary_int oc base.families.len; + output_binary_int oc base.couples.len; + output_binary_int oc base.strings.len; + return + let array_start_indexes = pos_out oc in + do output_binary_int oc 0; + output_binary_int oc 0; + output_binary_int oc 0; + output_binary_int oc 0; + output_binary_int oc 0; + return + let persons_array_pos = pos_out oc in + do output_array (base.persons.array ()); return + let ascends_array_pos = pos_out oc in + do output_array (base.ascends.array ()); return + let families_array_pos = pos_out oc in + do output_array (base.families.array ()); return + let couples_array_pos = pos_out oc in + do output_array (base.couples.array ()); return + let strings_array_pos = pos_out oc in + do output_array (base.strings.array ()); + seek_out oc array_start_indexes; + output_binary_int oc persons_array_pos; + output_binary_int oc ascends_array_pos; + output_binary_int oc families_array_pos; + output_binary_int oc couples_array_pos; + output_binary_int oc strings_array_pos; + close_out oc; + close_out oc_acc; +do Printf.eprintf "*** create name index\n"; flush stderr; return + output_binary_int oc_inx 0; + create_name_index oc_inx base; + let surname_or_first_name_pos = pos_out oc_inx in +do Printf.eprintf "*** create strings of fsname\n"; flush stderr; return + do create_strings_of_fsname oc_inx base; + seek_out oc_inx 0; + output_binary_int oc_inx surname_or_first_name_pos; + close_out oc_inx; + return (); +do Printf.eprintf "*** create string index\n"; flush stderr; return + output_strings_hash oc2 base; + let surname_pos = pos_out oc2 in +do Printf.eprintf "*** create surname index\n"; flush stderr; return + do output_surname_index oc2 base; return + let first_name_pos = pos_out oc2 in +do Printf.eprintf "*** create first name index\n"; flush stderr; return + do output_first_name_index oc2 base; + seek_out oc2 int_size; + output_binary_int oc2 surname_pos; + output_binary_int oc2 first_name_pos; + return (); +do Printf.eprintf "*** ok\n"; flush stderr; return + close_out oc2; + try Sys.remove (Filename.concat bname "gwb") with _ -> (); + Sys.rename tmp_fname (Filename.concat bname "gwb"); + try Sys.remove (Filename.concat bname "acc") with _ -> (); + Sys.rename tmp_fname_acc (Filename.concat bname "acc"); + try Sys.remove (Filename.concat bname "inx") with _ -> (); + Sys.rename tmp_fname_inx (Filename.concat bname "inx"); + try Sys.remove (Filename.concat bname "gw2") with _ -> (); + Sys.rename tmp_fname_gw2 (Filename.concat bname "gw2"); + try Sys.remove (Filename.concat bname "gw9") with _ -> (); + return () + with e -> + do try close_out oc with _ -> (); + try close_out oc_acc with _ -> (); + try close_out oc_inx with _ -> (); + try close_out oc2 with _ -> (); + try + do Sys.remove tmp_fname; + Sys.remove tmp_fname_acc; + Sys.remove tmp_fname_inx; + Sys.remove tmp_fname_gw2; + return () + with _ -> (); + return raise e +; diff --git a/src/iobase.mli b/src/iobase.mli new file mode 100644 index 0000000000..a349f60046 --- /dev/null +++ b/src/iobase.mli @@ -0,0 +1,10 @@ +(* $Id: iobase.mli,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +open Def; + +value magic_gwb : string; + +value input : string -> base; +value output : string -> base -> unit; + +value lock_file : string -> string; diff --git a/src/iovalue.ml b/src/iovalue.ml new file mode 100644 index 0000000000..1ce45ff2b7 --- /dev/null +++ b/src/iovalue.ml @@ -0,0 +1,233 @@ +(* camlp4r ./q_codes.cmo *) +(* $Id: iovalue.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +value string_tag = Obj.tag (Obj.repr "a"); +value float_tag = Obj.tag (Obj.repr 3.5); +value fun_tag = Obj.tag (Obj.repr (fun x -> x)); + +(* Input: + read inside a value output by output_value (no headers) must + match Ocaml's input_value system (intern.c) *) + +value sizeof_long = 4; +value sign_extend_shift = (sizeof_long - 1) * 8 - 1; +value sign_extend x = (x lsl sign_extend_shift) asr sign_extend_shift; + +type in_funs 'a = + { input_byte : 'a -> int; + input_binary_int : 'a -> int; + input : 'a -> string -> int -> int -> unit } +; + +value rec input_loop ifuns ic = + let code = ifuns.input_byte ic in + if code >= <> then + if code >= <> then + input_block ifuns ic (code land 0xf) ((code lsr 4) land 0x7) + else Obj.magic (code land 0x3f) + else if code >= <> then + let len = code land 0x1F in + let s = String.create len in + do ifuns.input ic s 0 len; return Obj.magic s + else + match code with + [ <> -> Obj.magic (sign_extend (ifuns.input_byte ic)) + | <> -> + let h = ifuns.input_byte ic in + Obj.magic ((sign_extend h) lsl 8 + ifuns.input_byte ic) + | <> -> + let x1 = ifuns.input_byte ic in + let x2 = ifuns.input_byte ic in + let x3 = ifuns.input_byte ic in + let x4 = ifuns.input_byte ic in + Obj.magic ((sign_extend x1) lsl 24 + x2 lsl 16 + x3 lsl 8 + x4) + | <> -> + let header = ifuns.input_binary_int ic in + Obj.magic (input_block ifuns ic (header land 0xff) (header lsr 10)) + | <> -> + let len = ifuns.input_byte ic in + let s = String.create len in + do ifuns.input ic s 0 len; return Obj.magic s + | <> -> + let len = ifuns.input_binary_int ic in + let s = String.create len in + do ifuns.input ic s 0 len; return Obj.magic s + | code -> failwith (Printf.sprintf "input bad code 0x%x" code) ] +and input_block ifuns ic tag size = + let v = + if tag == 0 then Obj.magic (Array.create size (Obj.magic 0)) + else Obj.new_block tag size + in + do for i = 0 to size - 1 do + let x = input_loop ifuns ic in + Obj.set_field v i (Obj.magic x); + done; + return v +; + +value in_channel_funs = + {input_byte = input_byte; + input_binary_int = input_binary_int; + input = really_input} +; + +value input ic = Obj.magic (input_loop in_channel_funs ic); +value gen_input ifuns i = Obj.magic (input_loop ifuns i); + +(* Output *) + +type sizes = + { size_32 : mutable int; + size_64 : mutable int } +; + +type out_funs 'a = + { output_byte : 'a -> int -> unit; + output_binary_int : 'a -> int -> unit; + output : 'a -> string -> int -> int -> unit } +; + +value rec output_loop sz ofuns oc x = + if not (Obj.is_block x) then + if Obj.magic x >= 0 && Obj.magic x < 0x40 then + ofuns.output_byte oc (<> + Obj.magic x) + else if Obj.magic x >= -128 && Obj.magic x < 128 then + do ofuns.output_byte oc <>; + ofuns.output_byte oc (Obj.magic x); + return () + else if Obj.magic x >= -32768 && Obj.magic x < 32768 then + do ofuns.output_byte oc <>; + ofuns.output_byte oc (Obj.magic x lsr 8); + ofuns.output_byte oc (Obj.magic x); + return () + else + do ofuns.output_byte oc <>; return + ofuns.output_binary_int oc (Obj.magic x) + else + if Obj.tag x == fun_tag then failwith "Iovalue.output " + else if Obj.tag x == string_tag then + let len = String.length (Obj.magic x) in + do if len < 0x20 then + ofuns.output_byte oc (<> + len) + else if len < 0x100 then + do ofuns.output_byte oc <>; + ofuns.output_byte oc len; + return () + else + do ofuns.output_byte oc <>; + ofuns.output_binary_int oc len; + return (); + ofuns.output oc (Obj.magic x) 0 len; + sz.size_32 := sz.size_32 + 1 + (len + 4) / 4; + sz.size_64 := sz.size_64 + 1 + (len + 8) / 8; + return () + else if Obj.tag x == float_tag then + failwith "Iovalue.output: floats not implemented" + else + do if Obj.tag x < 16 && Obj.size x < 8 then + ofuns.output_byte oc + (<> + Obj.tag x + Obj.size x lsl 4) + else + do ofuns.output_byte oc <>; + ofuns.output_binary_int oc (Obj.tag x + Obj.size x lsl 10); + return (); + for i = 0 to Obj.size x - 1 do + output_loop sz ofuns oc (Obj.field x i); + done; + sz.size_32 := sz.size_32 + 1 + Obj.size x; + sz.size_64 := sz.size_64 + 1 + Obj.size x; + return () +; + +value out_channel_funs = + {output_byte = output_byte; + output_binary_int = output_binary_int; + output = output} +; + +value sz = {size_32 = 0; size_64 = 0}; + +value output oc x = output_loop sz out_channel_funs oc (Obj.repr x); +value gen_output sz ofuns i x = output_loop sz ofuns i (Obj.repr x); + +(* Size *) + +value size_funs = + {output_byte = fun r _ -> incr r; + output_binary_int = fun r _ -> r.val := r.val + 4; + output = fun r _ beg len -> r.val := r.val + len - beg} +; + +value size = ref 0; + +value size v = + do size.val := 0; + gen_output sz size_funs size v; + return size.val; + +(* Digest *) + +value dbuf = ref (String.create 256); +value dlen = ref 0; +value dput_char c = + do if dlen.val = String.length dbuf.val then + let nlen = 2 * dlen.val in + let ndbuf = String.create nlen in + do String.blit dbuf.val 0 ndbuf 0 dlen.val; dbuf.val := ndbuf; return () + else (); + dbuf.val.[dlen.val] := c; + incr dlen; + return () +; +value rec dput_int i = + if i == 0 then () + else + do dput_char (Char.chr (Char.code '0' + i mod 10)); return + dput_int (i / 10) +; +value dput_string s = + for i = 0 to String.length s - 1 do + dput_char s.[i]; + done +; + +value hexchar i = + if i <= 9 then Char.chr (Char.code '0' + i) + else Char.chr (Char.code 'A' + i - 10) +; + +value string_code s = + let r = String.create (String.length s * 2) in + do for i = 0 to String.length s - 1 do + r.[2*i] := hexchar (Char.code s.[i] / 16); + r.[2*i+1] := hexchar (Char.code s.[i] mod 16); + done; + return r +; + +value rec digest_loop v = + if not (Obj.is_block v) then + let n = (Obj.magic v : int) in + do dput_char 'I'; dput_int n; return () + else if Obj.size v == 0 then + do dput_char 'T'; dput_int (Obj.tag v); return () + else if Obj.tag v == string_tag then + let s = (Obj.magic v : string) in + do dput_char 'S'; dput_int (String.length s); + dput_char '/'; dput_string s; + return () + else + do dput_char 'O'; dput_int (Obj.tag v); + dput_char '/'; dput_int (Obj.size v); + digest_fields v 0; + return () +and digest_fields v i = + if i == Obj.size v then () + else do digest_loop (Obj.field v i); return digest_fields v (i + 1) +; + +value digest v = + do dlen.val := 0; + digest_loop (Obj.repr v); + return string_code (Digest.substring dbuf.val 0 dlen.val) +; diff --git a/src/iovalue.mli b/src/iovalue.mli new file mode 100644 index 0000000000..c1127b2e57 --- /dev/null +++ b/src/iovalue.mli @@ -0,0 +1,31 @@ +(* $Id: iovalue.mli,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +value input : in_channel -> 'a; +value output : out_channel -> 'a -> unit; + +value size : 'a -> int; +value digest : 'a -> Digest.t; + +value sizeof_long : int; + +(* generic functions *) + +type in_funs 'a = + { input_byte : 'a -> int; + input_binary_int : 'a -> int; + input : 'a -> string -> int -> int -> unit } +; +value gen_input : in_funs 'a -> 'a -> 'b; +value in_channel_funs : in_funs in_channel; + +type sizes = + { size_32 : mutable int; + size_64 : mutable int } +; +type out_funs 'a = + { output_byte : 'a -> int -> unit; + output_binary_int : 'a -> int -> unit; + output : 'a -> string -> int -> int -> unit } +; +value gen_output : sizes -> out_funs 'a -> 'a -> 'b -> unit; +value out_channel_funs : out_funs out_channel; diff --git a/src/lock.ml b/src/lock.ml new file mode 100644 index 0000000000..f07b63e817 --- /dev/null +++ b/src/lock.ml @@ -0,0 +1,38 @@ +(* $Id: lock.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +type choice 'a 'b = [ Left of 'a | Right of 'b ]; + +value no_lock_flag = ref False; + +value control lname wait f = + if no_lock_flag.val then do f (); return True + else ifdef UNIX then + let fd = Unix.openfile lname [Unix.O_RDWR; Unix.O_CREAT] 0o666 in + do try Unix.chmod lname 0o666 with _ -> (); return + let r = + try + do if wait then Unix.lockf fd Unix.F_LOCK 0 + else Unix.lockf fd Unix.F_TLOCK 0; + return Left fd + with e -> Right e + in + match r with + [ Left fd -> + do try f () with e -> do Unix.close fd; return raise e; + Unix.close fd; + return True + | Right (Unix.Unix_error _ _ _) -> do Unix.close fd; return False + | Right exc -> do Unix.close fd; return raise exc ] + else + let r = + try Left (Unix.openfile lname [Unix.O_RDWR; Unix.O_CREAT] 0o666) with + e -> Right e + in + match r with + [ Left fd -> + do try f () with e -> do Unix.close fd; return raise e; + Unix.close fd; + return True + | Right (Unix.Unix_error _ _ _) -> False + | Right exc -> raise exc ] +; diff --git a/src/merge.ml b/src/merge.ml new file mode 100644 index 0000000000..312c90d6f2 --- /dev/null +++ b/src/merge.ml @@ -0,0 +1,76 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: merge.ml,v 1.1 1998-09-01 14:32:10 ddr Exp $ *) + +open Def; +open Config; +open Gutil; +open Util; + +value print_someone base p = + Wserver.wprint "%s%s %s" (sou base p.first_name) + (if p.occ == 0 then ""else "." ^ string_of_int p.occ) + (sou base p.surname) +; + +(* +value print_person conf base (first_name, surname, occ) = + tag "table" "border=1" begin + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" + (capitale (transl_nth conf "first name/first names" 0)); + end; + tag "td" begin + Wserver.wprint "" first_name; + end; + tag "td" "align=right" begin + let s = capitale (transl conf "number") in + let s = if String.length s > 3 then String.sub s 0 3 else s in + Wserver.wprint "%s" s; + end; + tag "td" begin + Wserver.wprint "\n" + (if occ == 0 then "" else " value=" ^ string_of_int occ); + end; + end; + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" + (capitale (transl_nth conf "surname/surnames" 0)); + end; + tag "td" "colspan=3" begin + Wserver.wprint + "\n" + surname; + end; + end; + end +; +*) + +value print conf base p = + let title h = + do Wserver.wprint "%s" (capitale (transl conf "merge")); + if h then () + else do Wserver.wprint ": "; print_someone base p; return (); + return () + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=GET action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (Adef.int_of_iper p.cle_index); + Wserver.wprint "%s " (capitale (transl conf "with")); + Wserver.wprint "(%s . %s %s):\n" + (transl_nth conf "first name/first names" 0) + (transl conf "number") (transl_nth conf "surname/surnames" 0); + Wserver.wprint "\n"; + Wserver.wprint "=>\n"; + Wserver.wprint "\n"; + end; + trailer conf; + return () +; diff --git a/src/merge.mli b/src/merge.mli new file mode 100644 index 0000000000..82c802da1a --- /dev/null +++ b/src/merge.mli @@ -0,0 +1,8 @@ +(* $Id: merge.mli,v 1.1 1998-09-01 14:32:10 ddr Exp $ *) + +open Def; +open Config; + +value print_someone : base -> base_person -> unit; +value print : config -> base -> base_person -> unit; + diff --git a/src/mergeFam.ml b/src/mergeFam.ml new file mode 100644 index 0000000000..2a3229afc5 --- /dev/null +++ b/src/mergeFam.ml @@ -0,0 +1,93 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: mergeFam.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Util; +open Gutil; + +value print_differences conf base branches fam1 fam2 = + let string_field title name proj = + let x1 = proj fam1 in + let x2 = proj fam2 in + if x1 <> "" && x2 <> "" && x1 <> x2 then + do Wserver.wprint "

      %s

      \n" (capitale title); + tag "ul" begin + Wserver.wprint "
    • \n"; + Wserver.wprint "\n" + name; + Wserver.wprint "%s\n" x1; + Wserver.wprint "
    • \n"; + Wserver.wprint "\n" name; + Wserver.wprint "%s\n" x2; + end; + return () + else () + in + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (Adef.int_of_ifam fam1.fam_index); + Wserver.wprint "\n" + (Adef.int_of_ifam fam2.fam_index); + loop branches where rec loop = + fun + [ [(ip1, ip2)] -> + do Wserver.wprint "\n" + (Adef.int_of_iper ip1); + Wserver.wprint "\n" + (Adef.int_of_iper ip2); + return () + | [_ :: branches] -> loop branches + | _ -> () ]; + Wserver.wprint "

      \n"; + string_field (transl_nth conf "marriage/marriages" 0) "marriage" + (fun fam -> + match Adef.od_of_codate fam.marriage with + [ None -> "" + | Some d -> Date.string_of_ondate conf d ]); + string_field + (transl_nth conf "marriage/marriages" 0 ^ " / " ^ transl conf "place") + "marriage_place" (fun fam -> sou base fam.marriage_place); + string_field (transl conf "divorce") "divorce" + (fun fam -> + match fam.divorce with + [ NotDivorced -> "" + | Divorced cod -> + match Adef.od_of_codate cod with + [ Some d -> Date.string_of_ondate conf d + | None -> "" ] ]); + Wserver.wprint "

      \n"; + Wserver.wprint "\n"; + end +; + +value merge_fam1 conf base fam1 fam2 = + let title h = + Wserver.wprint "%s / %s" (capitale (transl conf "merge")) + (capitale (transl_nth conf "family/families" 1)) + in + do header conf title; + print_differences conf base [] fam1 fam2; + trailer conf; + return () +; + +value merge_fam conf base fam1 fam2 = + let cpl1 = coi base fam1.fam_index in + let cpl2 = coi base fam2.fam_index in + if cpl1.father = cpl2.father && cpl1.mother = cpl2.mother then + merge_fam1 conf base fam1 fam2 + else incorrect_request conf +; + +value print conf base = + match (p_getint conf.env "f1", p_getint conf.env "f2") with + [ (Some f1, Some f2) -> + let fam1 = base.families.get f1 in + let fam2 = base.families.get f2 in + merge_fam conf base fam1 fam2 + | _ -> incorrect_request conf ] +; + diff --git a/src/mergeFamOk.ml b/src/mergeFamOk.ml new file mode 100644 index 0000000000..041009b971 --- /dev/null +++ b/src/mergeFamOk.ml @@ -0,0 +1,123 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: mergeFamOk.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Util; +open Gutil; + +value reconstitute conf base fam1 fam2 = + let field name proj null = + let x1 = proj fam1 in + let x2 = proj fam2 in + match p_getenv conf.env name with + [ Some "1" -> x1 + | Some "2" -> x2 + | _ -> if null x1 then x2 else x1 ] + in + {marriage = field "marriage" (fun f -> f.marriage) (\= Adef.codate_None); + marriage_place = + field "marriage_place" (fun f -> sou base f.marriage_place) (\= ""); + divorce = field "divorce" (fun f -> f.divorce) (\= NotDivorced); + children = + Array.map (UpdateFam.person_key base) + (Array.append fam1.children fam2.children); + comment = sou base fam1.comment; + origin_file = sou base fam1.origin_file; + fsources = + let n1 = sou base fam1.fsources in + let n2 = sou base fam2.fsources in + if n1 = "" then n2 + else if n2 = "" then n1 + else n1 ^ ", " ^ n2; + fam_index = fam1.fam_index} +; + +value print_merge1 conf base fam fam2 digest = + let title _ = + Wserver.wprint "%s / %s # %d" (capitale (transl conf "merge")) + (capitale (transl_nth conf "family/families" 1)) + (Adef.int_of_ifam fam.fam_index) + in + let cpl = + Gutil.map_couple_p (UpdateFam.person_key base) (coi base fam.fam_index) + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (Adef.int_of_ifam fam.fam_index); + Wserver.wprint "\n" digest; + Wserver.wprint "\n" + (Adef.int_of_ifam fam2.fam_index); + match (p_getint conf.env "ini1", p_getint conf.env "ini2") with + [ (Some i1, Some i2) -> + do Wserver.wprint "\n" i1; + Wserver.wprint "\n" i2; + return () + | _ -> () ]; + Wserver.wprint "\n"; + UpdateFam.print_family conf base fam cpl False; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_merge conf base = + match (p_getint conf.env "f1", p_getint conf.env "f2") with + [ (Some f1, Some f2) -> + let fam1 = base.families.get f1 in + let fam2 = base.families.get f2 in + let sfam = reconstitute conf base fam1 fam2 in + let digest = Update.digest_family fam1 in + print_merge1 conf base sfam fam2 digest + | _ -> incorrect_request conf ] +; + +value print_mod_merge_ok conf base wl fam cpl = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "merge done")) + in + do header conf title; + UpdateFamOk.print_family conf base wl fam cpl; + match (p_getint conf.env "ini1", p_getint conf.env "ini2") with + [ (Some ini1, Some ini2) -> + let p1 = base.persons.get ini1 in + let p2 = base.persons.get ini2 in + do Wserver.wprint "\n

      \n"; + stag "a" "href=%sm=MRG_IND;i=%d;i2=%d" (commd conf) ini1 ini2 + begin + Wserver.wprint "%s" (capitale (transl conf "continue merging")); + end; + Wserver.wprint "\n"; + Merge.print_someone base p1; + Wserver.wprint "\n%s\n" (transl conf "and"); + Merge.print_someone base p2; + Wserver.wprint "\n"; + return () + | _ -> () ]; + trailer conf; + return () +; + +value effective_mod_merge conf base sfam scpl = + match p_getint conf.env "i2" with + [ Some i2 -> + let fam2 = base.families.get i2 in + do UpdateFamOk.effective_del conf base fam2; return + let (fam, cpl) = UpdateFamOk.effective_mod conf base sfam scpl in + let wl = UpdateFamOk.all_checks_family conf base fam cpl in + do base.commit_patches (); + print_mod_merge_ok conf base wl fam cpl; + return () + | None -> incorrect_request conf ] +; + +value print_mod_merge conf base = + UpdateFamOk.print_mod_aux conf base (effective_mod_merge conf base) +; diff --git a/src/mergeInd.ml b/src/mergeInd.ml new file mode 100644 index 0000000000..0dd03a4504 --- /dev/null +++ b/src/mergeInd.ml @@ -0,0 +1,279 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: mergeInd.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Util; +open Gutil; + +value print_differences conf base branches p1 p2 = + let string_field title name proj = + let x1 = proj p1 in + let x2 = proj p2 in + if x1 <> "" && x1 <> "?" && x2 <> "" && x2 <> "?" && x1 <> x2 then + do Wserver.wprint "

      %s

      \n" (capitale title); + tag "ul" begin + Wserver.wprint "
    • \n"; + Wserver.wprint "\n" + name; + Wserver.wprint "%s\n" x1; + Wserver.wprint "
    • \n"; + Wserver.wprint "\n" name; + Wserver.wprint "%s\n" x2; + end; + return () + else () + in + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (Adef.int_of_iper p1.cle_index); + Wserver.wprint "\n" + (Adef.int_of_iper p2.cle_index); + loop branches where rec loop = + fun + [ [(ip1, ip2)] -> + do Wserver.wprint "\n" + (Adef.int_of_iper ip1); + Wserver.wprint "\n" + (Adef.int_of_iper ip2); + return () + | [_ :: branches] -> loop branches + | _ -> () ]; + Wserver.wprint "

      \n"; + string_field (transl_nth conf "first name/first names" 0) "first_name" + (fun p -> sou base p.first_name); + string_field (transl_nth conf "surname/surnames" 0) "surname" + (fun p -> sou base p.surname); + string_field (transl conf "number") "number" + (fun p -> string_of_int p.occ); + string_field (transl conf "photo") "photo" (fun p -> sou base p.photo); + string_field (transl conf "public name") "public_name" + (fun p -> sou base p.public_name); + string_field (transl conf "occupation") "occupation" + (fun p -> sou base p.occupation); + string_field (transl conf "sex") "sex" + (fun p -> + match p.sexe with + [ Masculin -> "M" + | Feminin -> "F" + | Neutre -> "" ]); + string_field (transl conf "access") "access" + (fun p -> + match p.access with + [ IfTitles -> "IfTitles" + | Private -> "Private" + | Public -> "Public" ]); + string_field (transl conf "birth") "birth" + (fun p -> + match Adef.od_of_codate p.birth with + [ None -> "" + | Some d -> Date.string_of_ondate conf d ]); + string_field (transl conf "birth" ^ " / " ^ transl conf "place") + "birth_place" (fun p -> sou base p.birth_place); + string_field (transl conf "baptism") "baptism" + (fun p -> + match Adef.od_of_codate p.baptism with + [ None -> "" + | Some d -> Date.string_of_ondate conf d ]); + string_field (transl conf "baptism" ^ " / " ^ transl conf "place") + "baptism_place" (fun p -> sou base p.baptism_place); + string_field (transl conf "death") "death" + (fun p -> + let is = 2 in + match p.death with + [ NotDead -> transl_nth conf "not dead" is + | Death dr cd -> + let s = + match dr with + [ Killed -> transl_nth conf "killed (in action)" is + | Murdered -> transl_nth conf "murdered" is + | Executed -> transl_nth conf "executed (legally killed)" is + | Disappeared -> transl_nth conf "disappeared" is + | Unspecified -> transl_nth conf "died" is ] + in + s ^ " " ^ Date.string_of_ondate conf (Adef.date_of_cdate cd) + | DeadYoung -> transl_nth conf "dead young" is + | DeadDontKnowWhen -> transl_nth conf "died" is + | DontKnowIfDead -> "" ]); + string_field (transl conf "death" ^ " / " ^ transl conf "place") + "death_place" (fun p -> sou base p.death_place); + string_field (transl conf "burial") "burial" + (fun p -> + let is = 2 in + match p.burial with + [ UnknownBurial -> "" + | Buried cod -> + transl_nth conf "buried" is ^ + (match Adef.od_of_codate cod with + [ None -> "" + | Some d -> " " ^ Date.string_of_ondate conf d ]) + | Cremated cod -> + transl_nth conf "cremated" is ^ + (match Adef.od_of_codate cod with + [ None -> "" + | Some d -> " " ^ Date.string_of_ondate conf d ]) ]); + string_field (transl conf "burial" ^ " / " ^ transl conf "place") + "burial_place" (fun p -> sou base p.burial_place); + Wserver.wprint "

      \n"; + Wserver.wprint "\n"; + end +; + +value merge_ind conf base branches p1 p2 = + let title h = + Wserver.wprint "%s / %s" (capitale (transl conf "merge")) + (capitale (transl_nth conf "person/persons" 1)) + in + do header conf title; + if branches <> [] then + do Wserver.wprint "%s:\n" + (capitale (transl conf "you must first merge")); + tag "ul" begin + Wserver.wprint "

    • \n"; + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p1) begin + Merge.print_someone base p1; + end; + Wserver.wprint "\n%s\n" (transl conf "and"); + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p2) begin + Merge.print_someone base p2; + end; + Wserver.wprint "\n"; + end; + Wserver.wprint "

      \n"; + return () + else (); + print_differences conf base branches p1 p2; + if branches <> [] then + do Wserver.wprint "

      \n"; + Wserver.wprint "%s:\n" + (capitale (transl_nth conf "branch/branches" 1)); + Wserver.wprint "

      \n"; + tag "table" begin + List.iter + (fun (ip1, ip2) -> + let p1 = poi base ip1 in + let p2 = poi base ip2 in + do tag "tr" begin + tag "td" begin + afficher_personne_referencee conf base p1; + Date.afficher_dates_courtes conf base p1; + end; + tag "td" begin + afficher_personne_referencee conf base p2; + Date.afficher_dates_courtes conf base p2; + end; + end; + return ()) + branches; + end; + return () + else (); + trailer conf; + return () +; + +value merge_fam_first conf base branches fam1 fam2 p1 p2 = + let title h = + Wserver.wprint "%s / %s" (capitale (transl conf "merge")) + (capitale (transl_nth conf "family/families" 1)) + in + do header conf title; + Wserver.wprint "%s:\n" + (capitale (transl conf "you must first merge the 2 families")); + tag "ul" begin + Wserver.wprint "

    • \n"; + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p1) begin + Merge.print_someone base p1; + end; + Wserver.wprint "\n%s\n" (transl conf "with"); + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p2) begin + Merge.print_someone base p2; + end; + Wserver.wprint "\n"; + end; + Wserver.wprint "

      \n"; + MergeFam.print_differences conf base branches fam1 fam2; + trailer conf; + return () +; + +value not_found_or_incorrect conf = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint "%s %s %s %s %s\n" + (capitale (transl conf "not found")) + (transl conf "or") + (transl conf "several answers") + (transl conf "or") + (transl conf "incorrect request"); + trailer conf; + return () +; + +value same_person conf = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint "%s\n" (capitale (transl conf "it is the same person!")); + trailer conf; + return () +; + +value different_sexes conf = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint "%s.\n" (capitale (transl conf "incompatible sexes")); + trailer conf; + return () +; + +value rec propose_ancestors_merge conf base branches ip1 ip2 = + let a1 = aoi base ip1 in + let a2 = aoi base ip2 in + let branches = [(ip1, ip2) :: branches] in + match (a1.parents, a2.parents) with + [ (Some ifam1, Some ifam2) when ifam1 <> ifam2 -> + let cpl1 = coi base ifam1 in + let cpl2 = coi base ifam2 in + if cpl1.father <> cpl2.father then + propose_ancestors_merge conf base branches cpl1.father cpl2.father + else if cpl1.mother <> cpl2.mother then + propose_ancestors_merge conf base branches cpl1.mother cpl2.mother + else + merge_fam_first conf base branches (foi base ifam1) (foi base ifam2) + (poi base cpl1.father) (poi base cpl1.mother) + | _ -> + merge_ind conf base branches (poi base ip1) (poi base ip2) ] +; + +value print conf base = + let p1 = + match p_getint conf.env "i" with + [ Some i1 -> Some (base.persons.get i1) + | None -> None ] + in + let p2 = + match (p_getenv conf.env "n", p_getint conf.env "i2") with + [ (Some n, _) -> + let ipl = Gutil.person_ht_find_all base n in + match ipl with + [ [ip2] -> Some (poi base ip2) + | _ -> None ] + | (_, Some i2) -> Some (base.persons.get i2) + | _ -> None ] + in + match (p1, p2) with + [ (Some p1, Some p2) -> + if p1.cle_index = p2.cle_index then same_person conf + else if p1.sexe <> p2.sexe && p1.sexe <> Neutre && p2.sexe <> Neutre + then different_sexes conf + else + let a1 = aoi base p1.cle_index in + let a2 = aoi base p2.cle_index in + if a1.parents <> None && a2.parents <> None + && a1.parents <> a2.parents then + propose_ancestors_merge conf base [] p1.cle_index p2.cle_index + else merge_ind conf base [] p1 p2 + | _ -> not_found_or_incorrect conf ] +; diff --git a/src/mergeIndOk.ml b/src/mergeIndOk.ml new file mode 100644 index 0000000000..2c483651f2 --- /dev/null +++ b/src/mergeIndOk.ml @@ -0,0 +1,193 @@ +(* camlp4r ./pa_lock.cmo ./pa_html.cmo *) +(* $Id: mergeIndOk.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Util; +open Gutil; + +value rec merge_lists l1 = + fun + [ [x2 :: l2] -> + if List.mem x2 l1 then merge_lists l1 l2 else merge_lists (l1 @ [x2]) l2 + | [] -> l1 ] +; + +value reconstitute conf base p1 p2 = + let field name proj null = + let x1 = proj p1 in + let x2 = proj p2 in + match p_getenv conf.env name with + [ Some "1" -> x1 + | Some "2" -> x2 + | _ -> if null x1 then x2 else x1 ] + in + let list conv proj = + let l1 = List.map conv (proj p1) in + let l2 = List.map conv (proj p2) in + merge_lists l1 l2 + in + {first_name = + field "first_name" (fun p -> sou base p.first_name) + (fun x -> x = "" || x = "?"); + surname = field "surname" (fun p -> sou base p.surname) + (fun x -> x = "" || x = "?"); + occ = field "number" (fun p -> p.occ) (\= 0); + photo = field "photo" (fun p -> sou base p.photo) (\= ""); + public_name = field "public_name" (fun p -> sou base p.public_name) (\= ""); + nick_names = list (sou base) (fun p -> p.nick_names); + aliases = list (sou base) (fun p -> p.aliases); + first_names_aliases = list (sou base) (fun p -> p.first_names_aliases); + surnames_aliases = list (sou base) (fun p -> p.surnames_aliases); + titles = list (map_title_strings (sou base)) (fun p -> p.titles); + occupation = field "occupation" (fun p -> sou base p.occupation) (\= ""); + sexe = field "sex" (fun p -> p.sexe) (\= Neutre); + access = field "access" (fun p -> p.access) (\= IfTitles); + birth = field "birth" (fun p -> p.birth) (\= Adef.codate_None); + birth_place = field "birth_place" (fun p -> sou base p.birth_place) (\= ""); + baptism = field "baptism" (fun p -> p.baptism) (\= Adef.codate_None); + baptism_place = + field "baptism_place" (fun p -> sou base p.baptism_place) (\= ""); + death = field "death" (fun p -> p.death) (\= DontKnowIfDead); + death_place = field "death_place" (fun p -> sou base p.death_place) (\= ""); + burial = field "burial" (fun p -> p.burial) (\= UnknownBurial); + burial_place = + field "burial_place" (fun p -> sou base p.burial_place) (\= ""); + family = [| |]; + notes = + let n1 = sou base p1.notes in + let n2 = sou base p2.notes in + if n1 = "" then n2 + else if n2 = "" then n1 + else n1 ^ "
      \n" ^ n2; + psources = + let n1 = sou base p1.psources in + let n2 = sou base p2.psources in + if n1 = "" then n2 + else if n2 = "" then n1 + else n1 ^ ", " ^ n2; + cle_index = p1.cle_index} +; + +value print_merge1 conf base p p2 digest = + let title _ = + Wserver.wprint "%s / %s # %d" (capitale (transl conf "merge")) + (capitale (transl_nth conf "person/persons" 0)) + (Adef.int_of_iper p.cle_index) + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + UpdateInd.merge_call conf; + Wserver.wprint "\n" + (Adef.int_of_iper p.cle_index); + Wserver.wprint "\n" digest; + Wserver.wprint "\n" + (Adef.int_of_iper p2.cle_index); + Wserver.wprint "\n"; + UpdateInd.print_person conf base p; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_merge conf base = + match (p_getint conf.env "i1", p_getint conf.env "i2") with + [ (Some i1, Some i2) -> + let p1 = base.persons.get i1 in + let p2 = base.persons.get i2 in + let p = reconstitute conf base p1 p2 in + let digest = Update.digest_person p1 in + print_merge1 conf base p p2 digest + | _ -> incorrect_request conf ] +; + +value print_mod_merge_ok conf base wl p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "merge done")) + in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n"; + Update.print_warnings conf base wl; + match (p_getint conf.env "ini1", p_getint conf.env "ini2") with + [ (Some ini1, Some ini2) -> + let p1 = base.persons.get ini1 in + let p2 = base.persons.get ini2 in + do Wserver.wprint "\n

      \n"; + stag "a" "href=%sm=MRG_IND;i=%d;i2=%d" (commd conf) ini1 ini2 + begin + Wserver.wprint "%s" (capitale (transl conf "continue merging")); + end; + Wserver.wprint "\n"; + Merge.print_someone base p1; + Wserver.wprint "\n%s\n" (transl conf "and"); + Merge.print_someone base p2; + Wserver.wprint "\n"; + return () + | _ -> () ]; + trailer conf; + return () +; + +value effective_mod_merge conf base p = + match p_getint conf.env "i2" with + [ Some i2 -> + let p2 = base.persons.get i2 in + let a1 = aoi base p.cle_index in + let a2 = aoi base p2.cle_index in + do match (a1.parents, a2.parents) with + [ (None, Some ifam) -> + let fam = foi base ifam in + replace 0 where rec replace i = + if fam.children.(i) = p2.cle_index then + do fam.children.(i) := p.cle_index; + a1.parents := Some ifam; + a2.parents := None; + base.patch_ascend p.cle_index a1; + base.patch_ascend p2.cle_index a2; + base.patch_family ifam fam; + return () + else replace (i + 1) + | _ -> () ]; + return + let p2_family = p2.family in + let p2_sexe = p2.sexe in + do UpdateIndOk.effective_del conf base p2; + p2.family := [| |]; + Update.update_misc_names_of_family base p2; + base.patch_person p2.cle_index p2; + return + let p = UpdateIndOk.effective_mod conf base p in + do for i = 0 to Array.length p2_family - 1 do + let ifam = p2_family.(i) in + let cpl = coi base ifam in + do match p2_sexe with + [ Masculin -> cpl.father := p.cle_index + | Feminin -> cpl.mother := p.cle_index + | Neutre -> assert False ]; + base.patch_couple ifam cpl; + return (); + done; + p.family := Array.append p.family p2_family; + base.patch_ascend p.cle_index a1; + Update.update_misc_names_of_family base p; + base.patch_person p.cle_index p; + Gutil.check_noloop_for_person_list base (Update.error conf base) [p]; + return + let wl = + UpdateIndOk.all_checks_person conf base p (aoi base p.cle_index) + in + do base.commit_patches (); + print_mod_merge_ok conf base wl p; + return () + | _ -> incorrect_request conf ] +; + +value print_mod_merge conf base = + UpdateIndOk.print_mod_aux conf base (effective_mod_merge conf base) +; diff --git a/src/mhashtbl.ml b/src/mhashtbl.ml new file mode 100644 index 0000000000..78ab58df7d --- /dev/null +++ b/src/mhashtbl.ml @@ -0,0 +1,112 @@ +(* camlp4o *) +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + +(* $Id: mhashtbl.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +(* Hash tables *) + +(* We do dynamic hashing, and we double the size of the table when + buckets become too long, but without re-hashing the elements. *) + +type ('a, 'b) t = + { mutable max_len: int; (* max length of a bucket *) + mutable data: ('a, 'b) bucketlist array } (* the buckets *) + +and ('a, 'b) bucketlist = + Empty + | Cons of 'a * 'b * ('a, 'b) bucketlist + +let create initial_size = + { max_len = 2; data = Array.create initial_size Empty } + +let clear h = + for i = 0 to Array.length h.data - 1 do + h.data.(i) <- Empty + done + +let resize h = + let n = Array.length h.data in + let newdata = Array.create (n+n) Empty in + Array.blit h.data 0 newdata 0 n; + Array.blit h.data 0 newdata n n; + h.data <- newdata; + h.max_len <- 2 * h.max_len + +let rec bucket_too_long n bucket = + if n < 0 then true else + match bucket with + Empty -> false + | Cons(_,_,rest) -> bucket_too_long (pred n) rest + +external hash_param : int -> int -> 'a -> int = "hash_univ_param" "noalloc" + +let add h key info = + let i = (hash_param 10 100 key) mod (Array.length h.data) in + let bucket = Cons(key, info, h.data.(i)) in + h.data.(i) <- bucket; +(* + if bucket_too_long h.max_len bucket then resize h +*)() + +let remove h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if k = key then next else Cons(k, i, remove_bucket next) in + let i = (hash_param 10 100 key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + +let find h key = + match h.data.((hash_param 10 100 key) mod (Array.length h.data)) with + Empty -> raise Not_found + | Cons(k1, d1, rest1) -> + if key = k1 then d1 else + match rest1 with + Empty -> raise Not_found + | Cons(k2, d2, rest2) -> + if key = k2 then d2 else + match rest2 with + Empty -> raise Not_found + | Cons(k3, d3, rest3) -> + if key = k3 then d3 else begin + let rec find = function + Empty -> + raise Not_found + | Cons(k, d, rest) -> + if key = k then d else find rest + in find rest3 + end + +let find_all h key = + let rec find_in_bucket = function + Empty -> + [] + | Cons(k, d, rest) -> + if k = key then d :: find_in_bucket rest else find_in_bucket rest in + find_in_bucket h.data.((hash_param 10 100 key) mod (Array.length h.data)) + +let iter f h = + let d = h.data in + let len = Array.length d in + for i = 0 to len - 1 do + let rec do_bucket = function + Empty -> + () + | Cons(k, d, rest) -> + if (hash_param 10 100 k) mod len = i + then begin f k d; do_bucket rest end + else do_bucket rest in + do_bucket d.(i) + done + +let hash x = hash_param 50 500 x diff --git a/src/mk_consang.ml b/src/mk_consang.ml new file mode 100644 index 0000000000..4964cdd203 --- /dev/null +++ b/src/mk_consang.ml @@ -0,0 +1,47 @@ +(* camlp4r ./pa_lock.cmo *) +(* $Id: mk_consang.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +value fname = ref ""; +value scratch = ref False; + +value usage = "usage: " ^ Sys.argv.(0) ^ " [-scratch] "; +value speclist = + [("-scratch", Arg.Set scratch, ": from scratch")] +; + +value main () = + do Argl.parse speclist (fun s -> fname.val := s) usage; + if fname.val = "" then + do Printf.eprintf "Missing file name\n"; + Printf.eprintf "Use option -help for usage\n"; + flush stderr; + return () + else (); + return + let f () = + let base = Iobase.input fname.val in + do if base.Def.has_family_patches then scratch.val := True else (); + Sys.catch_break True; + try Consang.compute_all_consang base scratch.val with + [ Sys.Break -> do Printf.eprintf "\n"; flush stderr; return () ]; + Iobase.output fname.val base; + return () + in + lock (Iobase.lock_file fname.val) with + [ Accept -> f () + | Refuse -> + do Printf.eprintf "Base is locked. Waiting... "; + flush stderr; + return + lock_wait (Iobase.lock_file fname.val) with + [ Accept -> + do Printf.eprintf "Ok\n"; + flush stderr; + return f () + | Refuse -> + do Printf.eprintf "\nSorry. Impossible to lock base.\n"; + flush stderr; + return exit 2 ] ] +; + +Printexc.catch main (); diff --git a/src/name.ml b/src/name.ml new file mode 100644 index 0000000000..fa32d3fb31 --- /dev/null +++ b/src/name.ml @@ -0,0 +1,202 @@ +(* $Id: name.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +(* Name.lower *) + +value lower s = + let rec name_len special i len = + if i == String.length s then len + else + match s.[i] with + [ 'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' | '0'..'9' | '.' -> + name_len 0 (i + 1) (len + special + 1) + | _ -> + if len == 0 then name_len 0 (i + 1) 0 + else name_len 1 (i + 1) len ] + in + let s' = String.create (name_len 0 0 0) in + let rec copy special i i' = + if i == String.length s then s' + else + match s.[i] with + [ 'a'..'z' | 'A'..'Z' | 'à'..'ý' | 'À'..'Ý' | '0'..'9' | '.' as c -> + let i' = + if special then do s'.[i'] := ' '; return i' + 1 else i' + in + let c = + match Char.lowercase c with + [ 'à' | 'á' | 'â' | 'ã' | 'ä' | 'å' | 'æ' -> 'a' + | 'ç' -> 'c' + | 'è' | 'é' | 'ê' | 'ë' -> 'e' + | 'ì' | 'í' | 'î' | 'ï' -> 'i' + | 'ñ' -> 'n' + | 'ò' | 'ó' | 'ô' | 'õ' | 'ö' -> 'o' + | 'ù' | 'ú' | 'û' | 'ü' -> 'u' + | 'ý' | 'ÿ' -> 'y' + | c -> c ] + in + do s'.[i'] := c; return copy False (i + 1) (i' + 1) + | c -> + if i' == 0 then copy False (i + 1) 0 + else copy True (i + 1) i' ] + in + copy False 0 0 +; + +(* Name.abbrev *) + +value abbrev_list = + [("a", None); ("d", None); ("de", None); ("di", None); ("of", None); + ("saint", Some "st"); ("sainte", Some "ste"); + ("van", None); ("von", None); ("zu", None)] +; + +value rec is_word s i p ip = + if ip == String.length p then + if i == String.length s then True + else if s.[i] = ' ' then True + else False + else + if i == String.length s then False + else if s.[i] == p.[ip] then is_word s (i+1) p (ip+1) + else False +; + +value rec search_abbrev s i = + fun + [ [(w, a) :: pl] -> + if is_word s i w 0 then Some (String.length w, a) + else search_abbrev s i pl + | [] -> None ] +; + +value abbrev s = + let rec name_len can_start_abbrev i i' = + if i >= String.length s then i' + else + match s.[i] with + [ ' ' -> name_len True (i + 1) (i' + 1) + | c -> + if can_start_abbrev then + match search_abbrev s i abbrev_list with + [ None -> name_len False (i + 1) (i' + 1) + | Some (n, Some a) -> name_len False (i + n) (i' + String.length a) + | Some (n, None) -> name_len True (i + n + 1) i' ] + else name_len False (i + 1) (i' + 1) ] + in + let len = name_len True 0 0 in + if len == String.length s then s + else + let s' = String.make len '@' in + let rec copy can_start_abbrev i i' = + if i >= String.length s then s' + else + match s.[i] with + [ ' ' -> do s'.[i'] := ' '; return copy True (i + 1) (i' + 1) + | c -> + if can_start_abbrev then + match search_abbrev s i abbrev_list with + [ None -> do s'.[i'] := c; return copy False (i + 1) (i' + 1) + | Some (n, Some a) -> + do String.blit a 0 s' i' (String.length a); return + copy False (i + n) (i' + String.length a) + | Some (n, None) -> copy True (i + n + 1) i' ] + else do s'.[i'] := c; return copy False (i + 1) (i' + 1) ] + in + copy True 0 0 +; + +(* Name.strip *) + +value strip s = + let rec name_len i len = + if i == String.length s then len + else if s.[i] == ' ' then name_len (i + 1) len + else name_len (i + 1) (len + 1) + in + let len = name_len 0 0 in + if len == String.length s then s + else + let s' = String.create len in + let rec copy i i' = + if i == String.length s then s' + else if s.[i] == ' ' then copy (i + 1) i' + else do s'.[i'] := s.[i]; return copy (i + 1) (i' + 1) + in + copy 0 0 +; + +(* Name.crush *) + +value roman_number s i = + let rec loop i = + if i == String.length s then Some i + else if s.[i] == ' ' then Some i + else + match s.[i] with + [ 'i' | 'v' | 'x' -> loop (i + 1) + | _ -> None ] + in + if i == 0 || s.[i-1] == ' ' then loop i else None +; + +value crush s = + let rec name_len i len first_vowel = + if i == String.length s then len + else if s.[i] == ' ' then name_len (i + 1) len True + else + match roman_number s i with + [ Some j -> name_len j (len + j - i) True + | _ -> + match s.[i] with + [ 'a' | 'e' | 'i' | 'o' | 'u' | 'y' -> + if first_vowel then name_len (i + 1) (len + 1) False + else name_len (i + 1) len False + | 'h' -> name_len (i + 1) len first_vowel + | 's' when i == String.length s - 1 || s.[i + 1] == ' ' -> + name_len (i + 1) len False + | c -> + if i > 0 && s.[i-1] == c then name_len (i + 1) len False + else name_len (i + 1) (len + 1) False ] ] + in + let len = name_len 0 0 True in + let s' = String.create len in + let rec copy i i' first_vowel = + if i == String.length s then s' + else if s.[i] == ' ' then copy (i + 1) i' True + else + match roman_number s i with + [ Some j -> + do for k = i to j - 1 do s'.[k+i'-i] := s.[k]; done; return + copy j (i' + j - i) True + | _ -> + match s.[i] with + [ 'a' | 'e' | 'i' | 'o' | 'u' | 'y' -> + if first_vowel then + do s'.[i'] := 'e'; return copy (i + 1) (i' + 1) False + else copy (i + 1) i' False + | 'h' -> + do if i > 0 && s.[i-1] == 'p' then s'.[i'-1] := 'f' else (); + return copy (i + 1) i' first_vowel + | 's' when i == String.length s - 1 || s.[i + 1] == ' ' -> + copy (i + 1) i' False + | c -> + if i > 0 && s.[i-1] == c then copy (i + 1) i' False + else + let c = + match c with + [ 'k' | 'q' -> 'c' + | 'z' -> 's' + | c -> c ] + in + do s'.[i'] := c; return copy (i + 1) (i' + 1) False ] ] + in + copy 0 0 True +; + +(* strip_lower *) + +value strip_lower s = strip (lower s); + +(* crush_lower *) + +value crush_lower s = crush (abbrev (lower s)); diff --git a/src/name.mli b/src/name.mli new file mode 100644 index 0000000000..121038ceac --- /dev/null +++ b/src/name.mli @@ -0,0 +1,31 @@ +(* $Id: name.mli,v 1.1 1998-09-01 14:32:04 ddr Exp $ *) + +value lower : string -> string; + (* Name.lower: + - uppercase -> lowercase + - no accents + - chars no letters and no numbers (except '.') => spaces (stripped) *) +value abbrev : string -> string; + (* Name.abbrev: suppress lowercase particles, shorten "saint" into "st" *) +value strip : string -> string; + (* Name.strip = name without spaces *) +value crush : string -> string; + (* Name.crush: + - no spaces + - roman numbers are keeped + - vowels are suppressed, except in words starting with a vowel, + where this vowel is converted into "e" + - "k" and "q" replaced by "c" + - "y" replaced by "i" + - "z" replaced by "s" + - "ph" replaced by "f" + - others "h" deleted + - s at end of words are deleted + - no double lowercase consons *) + +value strip_lower : string -> string; + (* strip_lower = strip o lower, as first comparison of names. + First names and Surnames comparison is strip_lower equality. *) +value crush_lower : string -> string; + (* crush_lower = crush o abbrev o lower, as second comparison of names. + In index by names, the "names" are crush_lowers *) diff --git a/src/num.ml b/src/num.ml new file mode 100644 index 0000000000..3ff36ef520 --- /dev/null +++ b/src/num.ml @@ -0,0 +1,140 @@ +(* $Id: num.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +type t = array int; + +value base = 0x1000000; + +value zero = [| |]; +value one = [| 1 |]; +value eq x y = x = y; +value twice x = + let l = + loop 0 0 where rec loop i r = + if i == Array.length x then + if r == 0 then [] else [r] + else + let v = x.(i) lsl 1 + r in + [v land (base - 1) :: loop (i + 1) (if v >= base then 1 else 0)] + in + Array.of_list l +; +value half x = + let l = + loop (Array.length x - 1) 0 [] where rec loop i r v = + if i < 0 then v + else + let rd = if x.(i) land 1 == 0 then 0 else base / 2 in + let v = + let d = r + x.(i) / 2 in + if d = 0 && v = [] then v else [d :: v] + in + loop (i - 1) rd v + in + Array.of_list l +; +value even x = + if Array.length x == 0 then True + else x.(0) land 1 == 0 +; +value inc x n = + let l = + loop 0 n where rec loop i r = + if i == Array.length x then + if r == 0 then [] else [r] + else + let d = x.(i) + r in + [d mod base :: loop (i + 1) (d / base)] + in + Array.of_list l +; +value normalize = + loop where rec loop = + fun + [ [] -> [] + | [x :: l] -> + let r = loop l in + if x == 0 && r = [] then r else [x :: r] ] +; +value sub x y = + let l = + loop 0 0 where rec loop i r = + if i >= Array.length x && i >= Array.length y then + if r == 0 then [] + else invalid_arg "Num.sub" + else + let (d, r) = + let xi = if i >= Array.length x then 0 else x.(i) in + let yi = if i >= Array.length y then 0 else y.(i) in + if yi + r <= xi then (xi - (yi + r), 0) + else (base + xi - (yi + r), 1) + in + [d :: loop (i + 1) r] + in + Array.of_list (normalize l) +; +value mul x n = + let l = + loop 0 0 where rec loop i r = + if i == Array.length x then + if r == 0 then [] else [r] + else + let d = x.(i) * n + r in + [d mod base :: loop (i + 1) (d / base)] + in + Array.of_list l +; +value div x n = + let l = + loop (Array.length x - 1) [] 0 where rec loop i l r = + if i < 0 then l + else + let r = r mod n * base + x.(i) in + let d = r / n in + loop (i - 1) [d :: l] r + in + Array.of_list (normalize l) +; +value modl x n = + let r = sub x (mul (div x n) n) in + if Array.length r == 0 then 0 else r.(0) +; + +value print sep x = + let digits = loop [] x + where rec loop d x = + if eq x zero then d + else loop [modl x 10 :: d] (div x 10) + in + let _ = + List.fold_left + (fun n d -> + do Wserver.wprint "%d" d; + if n > 0 && n mod 3 = 0 then Wserver.wprint "%s" sep else (); + return n - 1) + (List.length digits - 1) digits + in () +; +value to_string x = + let digits = loop [] x + where rec loop d x = + if eq x zero then d + else loop [modl x 10 :: d] (div x 10) + in + let s = String.create (List.length digits) in + let _ = + List.fold_left + (fun i d -> do s.[i] := Char.chr (Char.code '0' + d); return (i + 1)) + 0 digits + in + s +; + +value of_string s = + loop zero 0 where rec loop n i = + if i == String.length s then n + else + match s.[i] with + [ '0'..'9' -> + loop (inc (mul n 10) (Char.code s.[i] - Char.code '0')) (i + 1) + | _ -> failwith "Num.of_string" ] +; diff --git a/src/num.mli b/src/num.mli new file mode 100644 index 0000000000..336c52a7a0 --- /dev/null +++ b/src/num.mli @@ -0,0 +1,16 @@ +(* $Id: num.mli,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +type t = 'a; + +value zero : t; +value one : t; +value eq : t -> t -> bool; +value twice : t -> t; +value half : t -> t; +value even : t -> bool; +value inc : t -> int -> t; +value div : t -> int -> t; +value modl : t -> int -> int; +value print : string -> t -> unit; +value of_string : string -> t; +value to_string : t -> string; diff --git a/src/pa_html.ml b/src/pa_html.ml new file mode 100644 index 0000000000..888b2fbec6 --- /dev/null +++ b/src/pa_html.ml @@ -0,0 +1,52 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_html.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Pcaml; + +value rec unfold_apply list = + fun + [ <:expr< $x1$ $x2$ >> -> unfold_apply [x2 :: list] x1 + | e -> (e, list) ] +; + +value tag_encloser loc tag newl a el = + let s = if newl then "\n" else "" in + let e = + let (frm, al) = + match a with + [ Some e -> + let (e, al) = unfold_apply [] e in + let frm = + match e with + [ <:expr< $str:frm$ >> -> frm + | _ -> + Stdpp.raise_with_loc (MLast.loc_of_expr e) + (Stream.Error "string or 'do' expected") ] + in + (" " ^ frm, al) + | None -> ("", []) ] + in + List.fold_left (fun f e -> <:expr< $f$ $e$ >>) + <:expr< Wserver.wprint $str:"<" ^ tag ^ frm ^ ">" ^ s$ >> al + in + [e :: el @ [<:expr< Wserver.wprint $str:"" ^ s$ >>]] +; + +EXTEND + GLOBAL: expr; + expr: LEVEL "top" + [ [ "tag"; (tn, al, el) = tag_body -> + let el = tag_encloser loc tn True al el in + <:expr< do $list:el$ return () >> + | "stag"; (tn, al, el) = tag_body -> + let el = tag_encloser loc tn False al el in + <:expr< do $list:el$ return () >> ] ] + ; + tag_body: + [ [ tn = STRING; a = OPT expr; "begin"; el = LIST0 expr_semi; "end" -> + (tn, a, el) ] ] + ; + expr_semi: + [ [ e = expr; ";" -> e ] ] + ; +END; diff --git a/src/pa_lock.ml b/src/pa_lock.ml new file mode 100644 index 0000000000..4f0c4f2e23 --- /dev/null +++ b/src/pa_lock.ml @@ -0,0 +1,18 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(* $Id: pa_lock.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +EXTEND + Pcaml.expr: LEVEL "top" + [ [ "lock"; fn = Pcaml.expr; "with"; + "["; UIDENT "Accept"; "->"; ea = Pcaml.expr; + "|"; UIDENT "Refuse"; "->"; er = Pcaml.expr; "]" -> + <:expr< + if Lock.control $fn$ False (fun () -> $ea$) then () + else $er$ >> + | "lock_wait"; fn = Pcaml.expr; "with"; + "["; UIDENT "Accept"; "->"; ea = Pcaml.expr; + "|"; UIDENT "Refuse"; "->"; er = Pcaml.expr; "]" -> + <:expr< + if Lock.control $fn$ True (fun () -> $ea$) then () else $er$ >> ] ] + ; +END; diff --git a/src/perso.ml b/src/perso.ml new file mode 100644 index 0000000000..fc037018a1 --- /dev/null +++ b/src/perso.ml @@ -0,0 +1,628 @@ +(* $Id: perso.ml,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Def; +open Gutil; +open Util; +open Config; + +exception Ok; +value grand_parent_connu base a = + let rec loop niveau a = + if niveau = 2 then raise Ok + else + match a.parents with + [ Some ifam -> + let pere = (coi base ifam).father in + let mere = (coi base ifam).mother in + do loop (succ niveau) (aoi base pere); + loop (succ niveau) (aoi base mere); + return () + | _ -> () ] + in + try do loop 0 a; return False with [ Ok -> True ] +; + +value a_des_petits_enfants base p = + try + do Array.iter + (fun fi -> + let el = (foi base fi).children in + Array.iter + (fun e -> + Array.iter + (fun fi -> + let eel = (foi base fi).children in + Array.iter (fun _ -> raise Ok) eel) + (poi base e).family) + el) + p.family; + return False + with + [ Ok -> True ] +; + +value + print_title conf base and_txt p a first (nth, name, title, places, dates) = + do if not first then Wserver.wprint "," else (); + Wserver.wprint "\n\n" (commd conf) + (code_varenv (sou base title)) + (code_varenv (sou base (List.hd places))); + Wserver.wprint "%s" + (if first then capitale (sou base title) else sou base title); + Wserver.wprint " %s" (sou base (List.hd places)); + Wserver.wprint ""; + let rec loop places = + do match places with + [ [] -> () + | [_] -> Wserver.wprint "\n%s " and_txt + | _ -> Wserver.wprint ",\n" ]; + return + match places with + [ [place :: places] -> + do Wserver.wprint "\n" + (commd conf) (code_varenv (sou base title)) + (code_varenv (sou base place)); + Wserver.wprint "%s" (sou base place); + return loop places + | _ -> () ] + in + loop (List.tl places); + return + let paren = + match (nth, dates, name) with + [ (n, _, _) when n > 0 -> True + | (_, _, Tname _) -> True + | (_, [(Some _, _) :: _], _) -> age_autorise conf base p + | _ -> False ] + in + do if paren then Wserver.wprint "\n(" else (); return + let first = + if nth > 0 then + do Wserver.wprint "%s" (transl_nth conf "nth" nth); return False + else True + in + let first = + match name with + [ Tname n -> + do if not first then Wserver.wprint " ," else (); + Wserver.wprint "%s" (sou base n); + return False + | _ -> first ] + in + do if age_autorise conf base p && dates <> [(None, None)] then + let _ = + List.fold_left + (fun first (date_start, date_end) -> + do if not first then Wserver.wprint ",\n" else (); + match date_start with + [ Some d -> Wserver.wprint "%d" (annee d) + | None -> () ]; + match date_end with + [ Some d -> Wserver.wprint "-%d" (annee d) + | None -> () ]; + return False) + first dates + in + () + else (); + if paren then Wserver.wprint ")" else (); + return () +; + +value name_equiv n1 n2 = + n1 = n2 || n1 = Tmain && n2 = Tnone || n1 = Tnone && n2 = Tmain +; + +value print_titles conf base and_txt p a = + let titles = p.titles in + let titles = + List.fold_right + (fun t l -> + let t_date_start = Adef.od_of_codate t.t_date_start in + let t_date_end = Adef.od_of_codate t.t_date_end in + match l with + [ [(nth, name, title, place, dates) :: rl] + when + nth = t.t_nth && name_equiv name t.t_name && title = t.t_title && + place = t.t_place -> + [(nth, name, title, place, + [(t_date_start, t_date_end) :: dates]) :: + rl] + | _ -> + [(t.t_nth, t.t_name, t.t_title, t.t_place, + [(t_date_start, t_date_end)]) :: + l] ]) + titles [] + in + let titles = + List.fold_right + (fun (t_nth, t_name, t_title, t_place, t_dates) l -> + match l with + [ [(nth, name, title, places, dates) :: rl] + when + nth = t_nth && name_equiv name t_name && title = t_title && + dates = t_dates -> + [(nth, name, title, [t_place :: places], dates) :: rl] + | _ -> [(t_nth, t_name, t_title, [t_place], t_dates) :: l] ]) + titles [] + in + let _ = + List.fold_left + (fun first t -> + do print_title conf base and_txt p a first t; return False) + True titles + in + () +; + +value print_dates conf base p = + let is = index_of_sex p.sexe in + do if age_autorise conf base p then + let birth_place = sou base p.birth_place in + do match (Adef.od_of_codate p.birth, birth_place) with + [ (None, "") -> () + | _ -> Wserver.wprint "\n" ]; + match Adef.od_of_codate p.birth with + [ Some d -> + let anniv = + match (d, p.death) with + [ (Djma j1 m1 a1, NotDead) -> + match conf.today with + [ Djma j2 m2 a2 -> j1 == j2 && m1 == m2 + | _ -> False ] + | _ -> False ] + in + do Wserver.wprint "%s " (capitale (transl_nth conf "born" is)); + Wserver.wprint "%s" (Date.string_of_ondate conf d); + if anniv then + Wserver.wprint " (%s)" + (transl conf "happy birthday to you!") + else (); + return () + | None -> + if birth_place <> "" then + Wserver.wprint "%s\n" (capitale (transl_nth conf "born" is)) + else () ]; + if birth_place <> "" then Wserver.wprint " - %s" birth_place + else (); + match (Adef.od_of_codate p.birth, birth_place) with + [ (None, "") -> () + | _ -> Wserver.wprint ".
      \n" ]; + return () + else (); + if age_autorise conf base p then + let baptism = Adef.od_of_codate p.baptism in + let baptism_place = sou base p.baptism_place in + do match (baptism, baptism_place) with + [ (None, "") -> () + | _ -> Wserver.wprint "\n" ]; + match baptism with + [ Some d -> + do Wserver.wprint "%s " + (capitale (transl_nth conf "baptized" is)); + Wserver.wprint "%s" (Date.string_of_ondate conf d); + return () + | None -> + if baptism_place <> "" then + Wserver.wprint "%s\n" + (capitale (transl_nth conf "baptized" is)) + else () ]; + if baptism_place <> "" then Wserver.wprint " - %s" baptism_place + else (); + match (baptism, baptism_place) with + [ (None, "") -> () + | _ -> Wserver.wprint ".
      \n" ]; + return () + else (); + if age_autorise conf base p then + let death_place = sou base p.death_place in + let something = + match (p.death, death_place, p.burial) with + [ (DontKnowIfDead | NotDead, "", _) -> False + | (DeadDontKnowWhen, "", Buried _ | Cremated _) -> False + | _ -> True ] + in + do if something then Wserver.wprint "\n" else (); + match p.death with + [ Death dr d -> + let dr_w = + match dr with + [ Unspecified -> transl_nth conf "died" is + | Murdered -> transl_nth conf "murdered" is + | Killed -> transl_nth conf "killed (in action)" is + | Executed -> transl_nth conf "executed (legally killed)" is + | Disappeared -> transl_nth conf "disappeared" is ] + in + let d = Adef.date_of_cdate d in + do Wserver.wprint "%s " (capitale dr_w); + Wserver.wprint "%s" (Date.string_of_ondate conf d); + return () + | DeadYoung -> + Wserver.wprint "%s" (capitale (transl_nth conf "dead young" is)) + | DeadDontKnowWhen -> + match (death_place, p.burial) with + [ ("", Buried _ | Cremated _) -> () + | _ -> + Wserver.wprint "%s" (capitale (transl_nth conf "died" is)) ] + | DontKnowIfDead | NotDead -> () ]; + if death_place <> "" then Wserver.wprint " - %s" death_place + else (); + if something then Wserver.wprint ".
      \n" else (); + return () + else (); + if age_autorise conf base p then + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d, NotDead) -> + match d with + [ Da p _ when p <> Sure -> () + | d -> + let a = temps_ecoule d conf.today in + do Wserver.wprint "%s: " (capitale (transl conf "age")); + Date.print_age conf a; + Wserver.wprint ".
      \n"; + return () ] + | _ -> () ] + else (); + if age_autorise conf base p then + let sure = + fun + [ Djma _ _ _ | Dma _ _ | Da Sure _ -> True + | _ -> False ] + in + match (Adef.od_of_codate p.birth, p.death) with + [ (Some d1, Death _ d2) -> + let d2 = Adef.date_of_cdate d2 in + if sure d1 && sure d2 && d1 <> d2 then + let a = temps_ecoule d1 d2 in + do Wserver.wprint "%s " + (capitale (transl conf "death age:")); + Date.print_age conf a; + Wserver.wprint ".
      \n"; + return () + else () + | _ -> () ] + else (); + if age_autorise conf base p then + let something = + match p.burial with + [ Buried _ | Cremated _ -> True + | _ -> False ] + in + let burial_date_place cod = + let place = sou base p.burial_place in + do match Adef.od_of_codate cod with + [ Some d -> Wserver.wprint " %s" (Date.string_of_ondate conf d) + | None -> () ]; + if place <> "" then Wserver.wprint " - %s" place else (); + return () + in + do if something then Wserver.wprint "\n" else (); + match p.burial with + [ Buried cod -> + do Wserver.wprint "%s" (capitale (transl_nth conf "buried" is)); + burial_date_place cod; + return () + | Cremated cod -> + do Wserver.wprint "%s" + (capitale (transl_nth conf "cremated" is)); + burial_date_place cod; + return () + | UnknownBurial -> () ]; + if something then Wserver.wprint ".
      \n" else (); + return () + else (); + return () +; + +value print_parents conf base p = + match p.parents with + [ Some ifam -> + let ifath = (coi base ifam).father in + let imoth = (coi base ifam).mother in + let fath = poi base ifath in + let moth = poi base imoth in + do Wserver.wprint "

      %s

      \n\n
        \n
      • \n" + (capitale (transl conf "parents")); + afficher_personne_titre_referencee conf base fath; + Date.afficher_dates_courtes conf base fath; + Wserver.wprint "\n
      • \n"; + afficher_personne_titre_referencee conf base moth; + Date.afficher_dates_courtes conf base moth; + Wserver.wprint "\n
      \n\n"; + return () + | _ -> () ] +; + +value print_child conf base age_auth ip = + let p = poi base ip in + let a = aoi base ip in + let force_surname = + match a.parents with + [ None -> False + | Some ifam -> + sou base (poi base (coi base ifam).father).surname <> + sou base p.surname ] + in + do Wserver.wprint "\n
    • \n"; + if force_surname then afficher_personne_referencee conf base p + else afficher_prenom_de_personne_referencee conf base p; + if age_auth then Date.afficher_dates_courtes conf base p else (); + Wserver.wprint "\n"; + return () +; + +value print_family conf base p a ifam = + let fam = foi base ifam in + let marriage = Adef.od_of_codate fam.marriage in + let iconjoint = conjoint p (coi base ifam) in + let conjoint = poi base iconjoint in + let children = fam.children in + let divorce = fam.divorce in + let is = index_of_sex p.sexe in + do Wserver.wprint "\n
    • \n"; + Wserver.wprint + (fcapitale + (ftransl_nth conf "allied%t (euphemism for married or... not) to" + is)) + (fun _ -> + if age_autorise conf base p && age_autorise conf base conjoint then + let marriage_place = sou base fam.marriage_place in + do match (marriage, marriage_place) with + [ (None, "") -> () + | _ -> Wserver.wprint "\n" ]; + match marriage with + [ Some d -> Wserver.wprint "%s" (Date.string_of_ondate conf d) + | _ -> () ]; + match marriage_place with + [ "" -> () + | s -> Wserver.wprint " - %s, " s ]; + match (marriage, marriage_place) with + [ (None, "") -> () + | _ -> Wserver.wprint "" ]; + return () + else ()); + Wserver.wprint "\n"; + afficher_personne_titre_referencee conf base (poi base iconjoint); + Date.afficher_dates_courtes conf base (poi base iconjoint); + match divorce with + [ Divorced d -> + let d = Adef.od_of_codate d in + do Wserver.wprint ",\n%s" (transl conf "divorced"); + match d with + [ Some d + when + age_autorise conf base p && age_autorise conf base conjoint -> + do Wserver.wprint " "; + Wserver.wprint "%s" (Date.string_of_ondate conf d); + Wserver.wprint ""; + return () + | _ -> () ]; + return () + | _ -> () ]; + match sou base fam.comment with + [ "" -> () + | str -> Wserver.wprint "\n(%s)" str ]; + if Array.length children == 0 then () + else + let age_auth = + List.for_all (fun ip -> age_autorise conf base (poi base ip)) + (Array.to_list children) + in + do Wserver.wprint ", %s\n
        " (transl conf "having as children"); + Array.iter (print_child conf base age_auth) children; + Wserver.wprint "
      "; + return (); + Wserver.wprint "\n"; + if conf.wizard then + match p_getenv conf.henv "from" with + [ Some _ -> + let n = sou base fam.origin_file in + if n = "" then () else Wserver.wprint "(%s)
      \n" n + | None -> () ] + else (); + return () +; + +value print_families conf base p a = + match Array.to_list p.family with + [ [] -> () + | faml -> + do Wserver.wprint "

      %s %s %s

      \n\n
        " + (capitale (transl_nth conf "marriage/marriages" 1)) + (transl conf "and") (transl_nth conf "child/children" 1); + List.iter (print_family conf base p a) faml; + Wserver.wprint "
      \n"; + return () ] +; + +value print_notes conf base p = + match sou base p.notes with + [ "" -> () + | notes -> + if age_autorise conf base p then + do Wserver.wprint "

      %s

      \n\n" + (capitale (transl_nth conf "note/notes" 1)); + Wserver.wprint "
      • \n"; + Wserver.wprint "%s\n" notes; + Wserver.wprint "
      \n"; + return () + else () ] +; + +value print_sources conf base p = + let first = ref True in + do let sources = sou base p.psources in + if sources = "" then () + else + do first.val := False; return + Wserver.wprint "

      %s: %s\n" + (capitale (transl conf "sources")) sources; + for i = 0 to Array.length p.family - 1 do + let fam = foi base p.family.(i) in + let sources = sou base fam.fsources in + if sources = "" then () + else + do Wserver.wprint "%s" (if first.val then "

      " else "
      "); + first.val := False; + Wserver.wprint "%s %s%s: %s\n" + (capitale (transl conf "sources")) + (transl_nth conf "marriage/marriages" 0) + (if Array.length p.family == 1 then "" + else " " ^ string_of_int (i + 1)) + sources; + return (); + done; + return () +; + +value round_2_dec x = floor (x *. 100.0 +. 0.5) /. 100.0; + +value print conf base p = + let title h = + match (sou base p.public_name, p.nick_names) with + [ (n, [nn :: _]) when n <> "" -> + if h then Wserver.wprint "%s %s" n (sou base nn) + else Wserver.wprint "%s %s" n (sou base nn) + | (n, []) when n <> "" -> Wserver.wprint "%s %s" n (sou base p.surname) + | (_, [nn :: _]) -> + if h then Wserver.wprint "%s %s" (sou base p.first_name) (sou base nn) + else + Wserver.wprint "%s %s" (sou base p.first_name) + (sou base nn) + | (_, []) -> + if h then + Wserver.wprint "%s %s" (sou base p.first_name) (sou base p.surname) + else + do Wserver.wprint "%s" (commd conf) + (code_varenv (sou base p.first_name)) (sou base p.first_name); + Wserver.wprint " "; + Wserver.wprint "%s" (commd conf) + (code_varenv (sou base p.surname)) (sou base p.surname); + return () ] + in + let a = aoi base p.cle_index in + do header conf title; + Wserver.wprint "" (commd conf); + Wserver.wprint "welcome" + (commd conf); + Wserver.wprint "\n"; + if age_autorise conf base p then + match sou base p.photo with + [ "" -> () + | s -> + let http = "http://" in + if String.length s > String.length http && + String.sub s 0 (String.length http) = http then + Wserver.wprint "\"%s\"

      \n" s s + else if Filename.is_implicit s then + let fname = + List.fold_right Filename.concat [Util.base_dir.val; "images"] s + in + if Sys.file_exists fname then + Wserver.wprint "\"%s\"

      \n" + (commd conf) s s + else () + else () ] + else (); + match (p.public_name, p.nick_names) with + [ (n, [_ :: nnl]) when sou base n <> "" -> + let n = sou base n in + List.iter + (fun nn -> Wserver.wprint "%s %s
      \n" n (sou base nn)) + nnl + | (_, [_ :: nnl]) -> + let n = sou base p.first_name in + List.iter + (fun nn -> Wserver.wprint "%s %s
      \n" n (sou base nn)) + nnl + | _ -> () ]; + let is = index_of_sex p.sexe in + List.iter + (fun a -> + Wserver.wprint "%s %s
      \n" + (capitale (transl conf "alias")) (sou base a)) + p.aliases; + if List.length p.titles > 0 && + (p.access <> Private || conf.friend || conf.wizard) then + do Wserver.wprint ""; + print_titles conf base (transl conf "and") p a; + Wserver.wprint ".
      \n"; + return () + else (); + match (sou base p.public_name, p.nick_names) with + [ ("", []) -> () + | _ -> + do Wserver.wprint "(%s" (commd conf) + (code_varenv (sou base p.first_name)) (sou base p.first_name); + Wserver.wprint " "; + Wserver.wprint "%s)\n
      \n" + (commd conf) (code_varenv (sou base p.surname)) + (sou base p.surname); + return () ]; + List.iter + (fun n -> + Wserver.wprint "(%s %s)\n
      \n" (sou base p.first_name) + (sou base n)) + p.surnames_aliases; + if age_autorise conf base p then + List.iter + (fun n -> + Wserver.wprint "(%s %s)\n
      \n" (sou base n) + (sou base p.surname)) + p.first_names_aliases + else (); + match + (sou base p.public_name, p.nick_names, p.aliases, + List.length p.titles <> 0) + with + [ ("", [], _, _) | (_, _, [_ :: _], _) | (_, _, _, True) -> + Wserver.wprint "

      \n" + | _ -> () ]; + match sou base p.occupation with + [ "" -> () + | s -> + if age_autorise conf base p then + Wserver.wprint "%s.\n
      \n" (capitale s) + else () ]; + print_dates conf base p; + if age_autorise conf base p && a.consang != Adef.fix (-1) && + a.consang != Adef.fix 0 then + do Wserver.wprint "%s: " (capitale (transl conf "consanguinity")); + print_decimal_num conf + (round_2_dec (Adef.float_of_fix a.consang *. 100.0)); + Wserver.wprint "%%
      \n"; + return () + else (); + print_parents conf base a; + print_families conf base p a; + print_notes conf base p; + Wserver.wprint "\n

      \n\n%s\n

      \n" + (commd conf) (acces conf base p) + (capitale (transl conf "relationship computing")); + if grand_parent_connu base a then + Wserver.wprint "\n

      \n\n%s\n

      \n" + (commd conf) (acces conf base p) (capitale (transl conf "ancestors")) + else (); + if a_des_petits_enfants base p then + Wserver.wprint "\n

      \n\n%s\n

      \n" + (commd conf) (acces conf base p) + (capitale (transl conf "descendants")) + else (); + if conf.wizard then + Wserver.wprint "\n

      \n\n%s\n

      \n" + (commd conf) (acces conf base p) (capitale (transl conf "update")) + else (); + if age_autorise conf base p then print_sources conf base p else (); + match p_getenv conf.env "misc" with + [ Some "x" -> + do Wserver.wprint "
        "; + Wserver.wprint "\n
      1. %s\n" + (Name.lower (sou base p.first_name ^ " " ^ sou base p.surname)); + List.iter (fun x -> Wserver.wprint "\n
      2. %s\n" x) + (Gutil.person_misc_names base p); + Wserver.wprint "
      \n"; + return () + | _ -> () ]; + trailer conf; + return () +; diff --git a/src/phonygwd.ml b/src/phonygwd.ml new file mode 100644 index 0000000000..0e69b6b974 --- /dev/null +++ b/src/phonygwd.ml @@ -0,0 +1,74 @@ +(* $Id: phonygwd.ml,v 1.1 1998-09-01 14:32:12 ddr Exp $ *) + +open Unix; + +value port_selected = ref 2317; +value fname = ref ""; + +value log addr request s = + let referer = Wserver.extract_param "referer: " '\n' request in + let user_agent = Wserver.extract_param "user-agent: " '\n' request in + do let tm = Unix.localtime (Unix.time ()) in + Printf.eprintf "%02d/%02d/%02d %02d:%02d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) tm.Unix.tm_year tm.Unix.tm_hour tm.Unix.tm_min; + Printf.eprintf " %s\n" s; + match addr with + [ ADDR_UNIX x -> () + | ADDR_INET iaddr port -> + Printf.eprintf " From: %s\n" + (try (gethostbyaddr iaddr).h_name with _ -> + string_of_inet_addr iaddr) ]; + Printf.eprintf " Agent: %s\n" user_agent; + if referer <> "" then Printf.eprintf " Referer: %s\n" referer else (); + flush Pervasives.stderr; + return () +; + +value print_text fname = + let ic = open_in fname in + do try + while True do + print_char (input_char ic); + done + with + [ End_of_file -> () ]; + close_in ic; + Wserver.wflush (); + return () +; + +value connection (addr, request) str = + do log addr request str; + Wserver.html (); + print_text fname.val; + Wserver.wflush (); + return () +; + +value main () = + let usage = "Usage: " ^ Sys.argv.(0) ^ " [-p #] " in + let speclist = + [("-p", Arg.Int (fun x -> port_selected.val := x), "#: port number")] + in + do Argl.parse speclist (fun s -> fname.val := s) usage; + if fname.val = "" then + do Printf.eprintf "Missing file\n"; + Printf.eprintf "Use option -help for usage\n"; + flush Pervasives.stderr; + return exit 1 + else (); + close_in (open_in fname.val); + Wserver.f port_selected.val 0 (Some 4) None connection; + return () +; + +try + main () +with +[ Unix_error err fun_name arg -> + do Printf.eprintf "Error: \"%s\", %s\n" fun_name (error_message err); + flush Pervasives.stderr; + return exit 1 +| exc -> Printexc.catch raise exc ] +; + diff --git a/src/pqueue.ml b/src/pqueue.ml new file mode 100644 index 0000000000..33dde48ad1 --- /dev/null +++ b/src/pqueue.ml @@ -0,0 +1,56 @@ +(* $Id: pqueue.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +module type OrderedType = sig type t = 'a; value leq : t -> t -> bool; end; + +module type S = + sig + type elt = 'a; + type t = 'a; + value empty : t; + value is_empty : t -> bool; + value add : elt -> t -> t; + value take : t -> (elt * t); + value union : t -> t -> t; + end +; + +module Make (Ord : OrderedType) = + struct + type elt = Ord.t; + type t = list tree and tree = { node : elt; rank : int; list : t }; + value link t1 t2 = + if Ord.leq t1.node t2.node then + {node = t1.node; rank = t1.rank + 1; list = [t2 :: t1.list]} + else {node = t2.node; rank = t2.rank + 1; list = [t1 :: t2.list]} + ; + value rec ins t = + fun + [ [] -> [t] + | [t' :: ts] -> + if t.rank < t'.rank then [t; t' :: ts] else ins (link t t') ts ] + ; + value rec union fts1 fts2 = + match (fts1, fts2) with + [ ([], ts) -> ts + | (ts, []) -> ts + | ([t1 :: ts1], [t2 :: ts2]) -> + if t1.rank < t2.rank then [t1 :: union ts1 fts2] + else if t2.rank < t1.rank then [t2 :: union fts1 ts2] + else ins (link t1 t2) (union ts1 ts2) ] + ; + value empty : t = []; + value is_empty (q : t) = q = []; + value add x q = ins {node = x; rank = 0; list = []} q; + value take ts = + let rec getMin = + fun + [ [] -> raise Not_found + | [t] -> (t, []) + | [t :: ts] -> + let (t', ts') = getMin ts in + if Ord.leq t.node t'.node then (t, ts) else (t', [t :: ts']) ] + in + let (t, ts) = getMin ts in (t.node, union (List.rev t.list) ts) + ; + end +; diff --git a/src/pqueue.mli b/src/pqueue.mli new file mode 100644 index 0000000000..6674ae8f83 --- /dev/null +++ b/src/pqueue.mli @@ -0,0 +1,32 @@ +(* $Id: pqueue.mli,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +(* Module [Pqueue]: priority queues. *) + +(* This module implements priority queues, given a total ordering function + over the elements inserted. All operations are purely applicative + (no side effects). + The implementation uses binomial queues from Chris Okasak. + "add", "take" and "union" are in o(log n) in the worst case. *) + +module type OrderedType = sig type t = 'a; value leq : t -> t -> bool; end; + (* The input signature of the functor [Pqueue.Make]. + [t] is the type of the inserted elements. + [leq] is a total ordering function over the elements. + This is a two-argument function [f] returning [True] if the + first argument is less or equal to the second one. *) + +module type S = + sig + type elt = 'a; + type t = 'a; + value empty : t; + value is_empty : t -> bool; + value add : elt -> t -> t; + value take : t -> (elt * t); + value union : t -> t -> t; + end +; + +module Make (Ord : OrderedType) : + S with type elt = Ord.t +; diff --git a/src/pr_transl.ml b/src/pr_transl.ml new file mode 100644 index 0000000000..fa5f146727 --- /dev/null +++ b/src/pr_transl.ml @@ -0,0 +1,91 @@ +(* camlp4r q_MLast.cmo *) +(* $Id: pr_transl.ml,v 1.1 1998-09-01 14:32:12 ddr Exp $ *) + +open MLast; + +value not_impl name x = + let desc = + if Obj.is_block (Obj.repr x) then + "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) + else "int_val = " ^ string_of_int (Obj.magic x) + in + failwith ("Pr_transl." ^ name ^ ": not impl " ^ desc) +; + +value trace = + ["transl"; "transl_nth"; "transl_concat"; "ftransl"; "ftransl_nth"] +; + +value rec expr e = + match e with + [ <:expr< $lid:f$ $_$ $str:s$ >> when List.mem f trace -> + Printf.printf "%s\n" s + | <:expr< $lid:f$ $_$ ($lid:g$ $_$ $str:s$ $_$) >> when + List.mem f trace && List.mem g trace -> +(* + Printf.printf "INDIRECT %s\n" s +*) + Printf.printf "%s\n" s +(**) + | <:expr< $lid:x$ >> when List.mem x trace -> + Stdpp.raise_with_loc (MLast.loc_of_expr e) (Failure "Bad source") + | <:expr< let $rec:_$ $list:pel$ in $e$ >> -> + do binding_list pel; expr e; return () + | <:expr< fun [ $list:pel$ ] >> -> List.iter fun_binding pel + | <:expr< match $e$ with [ $list:pel$ ] >> -> + do expr e; List.iter fun_binding pel; return () + | <:expr< try $e$ with [ $list:pel$ ] >> -> + do expr e; List.iter fun_binding pel; return () + | <:expr< do $list:el$ return $e$ >> -> + do List.iter expr el; expr e; return () + | <:expr< if $e1$ then $e2$ else $e3$ >> -> + do expr e1; expr e2; expr e3; return () + | <:expr< for $_$ = $_$ $to:_$ $_$ do $list:el$ done >> -> + List.iter expr el + | <:expr< while $_$ do $list:el$ done >> -> List.iter expr el + | <:expr< ($list:el$) >> -> List.iter expr el + | <:expr< ($e$:$_$) >> -> expr e + | <:expr< [| $list:el$ |] >> -> List.iter expr el + | <:expr< $x$ $y$ >> -> do expr x; expr y; return () + | <:expr< { $list:fel$ } >> -> List.iter (fun (_, e) -> expr e) fel + | <:expr< $_$ := $_$ >> -> () + | <:expr< $_$.($_$) >> -> () + | <:expr< $_$.[$_$] >> -> () + | <:expr< $lid:_$ >> -> () + | <:expr< $uid:_$ >> -> () + | <:expr< $str:_$ >> -> () + | <:expr< $int:_$ >> -> () + | <:expr< $flo:_$ >> -> () + | <:expr< $chr:_$ >> -> () + | <:expr< $x$.$y$ >> -> () + | x -> not_impl "expr" x ] +and binding_list pel = List.iter binding pel +and binding (p, e) = + match p with + [ <:patt< $lid:s$ >> when List.mem s trace -> () + | _ -> expr e ] +and fun_binding (p, _, e) = expr e +; + +value rec module_expr = + fun + [ <:module_expr< $_$ . $_$ >> -> () + | <:module_expr< $me1$ $me2$ >> -> + do module_expr me1; module_expr me2; return () + | <:module_expr< struct $list:sil$ end >> -> List.iter str_item sil + | x -> not_impl "module_expr" x ] +and str_item = + fun + [ <:str_item< declare $list:sil$ end >> -> List.iter str_item sil + | <:str_item< open $_$ >> -> () + | <:str_item< value $rec:_$ $list:pel$ >> -> binding_list pel + | <:str_item< type $list:_$ >> -> () + | <:str_item< exception $_$ of $list:_$ >> -> () + | <:str_item< module $_$ = $me$ >> -> module_expr me + | <:str_item< $exp:e$ >> -> expr e + | x -> not_impl "str_item" x ] +; + +value f (ast, loc) = do str_item ast; flush stdout; return (); + +Pcaml.print_implem.val := List.iter f; diff --git a/src/q_codes.ml b/src/q_codes.ml new file mode 100644 index 0000000000..16e93e6f42 --- /dev/null +++ b/src/q_codes.ml @@ -0,0 +1,26 @@ +(* $Id: q_codes.ml,v 1.1 1998-09-01 14:32:03 ddr Exp $ *) + +value f _ = + fun + [ "PREFIX_SMALL_BLOCK" -> "0x80" + | "PREFIX_SMALL_INT" -> "0x40" + | "PREFIX_SMALL_STRING" -> "0x20" + | "CODE_INT8" -> "0x0" + | "CODE_INT16" -> "0x1" + | "CODE_INT32" -> "0x2" + | "CODE_BLOCK32" -> "0x8" + | "CODE_STRING8" -> "0x9" + | "CODE_STRING32" -> "0xA" +(* + | "CODE_NZEROS8" -> "0x4" + | "CODE_NZEROS32" -> "0x5" +*) + | "CODE_DOUBLE_NATIVE" -> "11" + | x -> + Stdpp.raise_with_loc (0, String.length x) + (Failure ("bad code " ^ x)) ] +; + +Quotation.add "codes" (Quotation.ExStr f); +Quotation.default.val := "codes"; + diff --git a/src/relation.ml b/src/relation.ml new file mode 100644 index 0000000000..a55aca1973 --- /dev/null +++ b/src/relation.ml @@ -0,0 +1,408 @@ +(* $Id: relation.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Gutil; +open Config; +open Util; + +value print_menu conf base p = + let title h = + do Wserver.wprint "%s " (capitale (transl conf "link between")); + if h then + match sou base p.public_name with + [ "" -> + Wserver.wprint "%s %s" (sou base p.first_name) (sou base p.surname) + | n -> Wserver.wprint "%s" n ] + else Wserver.wprint "%s" (person_text conf base p); + Wserver.wprint " %s..." (transl conf "and"); + return () + in + let is = index_of_sex p.sexe in + do header conf title; + Wserver.wprint "
        \n"; + Wserver.wprint "
      • \n" conf.command; + Srcfile.hidden_env conf; + Wserver.wprint + " + + + => + +
          +
        • +%s %s %s %s %s %s +
        • %s +
        • %s +" (Adef.int_of_iper p.cle_index) + (capitale (transl_nth conf "first name/first names" 0)) + (transl_nth conf "surname/surnames" 0) + (transl conf "or") (transl conf "public name") + (transl conf "or") (transl conf "alias") + (capitale (transl_nth conf "first name/first names" 0)) + (capitale (transl_nth conf "surname/surnames" 0)); + Wserver.wprint "
        \n\n"; + Array.iter + (fun ifam -> + let cpl = coi base ifam in + let c = conjoint p cpl in + let c = poi base c in + if sou base c.first_name <> "?" || sou base c.surname <> "?" then + do Wserver.wprint "
      • \n%s\n" + (capitale (transl_nth conf "his wife/her husband" is)); + Wserver.wprint "\n" (commd conf) + (code_varenv + ("m=R;i=" ^ + string_of_int (Adef.int_of_iper p.cle_index))) + (Adef.int_of_iper c.cle_index); + afficher_personne_sans_titre conf base c; + Wserver.wprint "\n"; + afficher_titre conf base c; + Wserver.wprint "\n"; + return () + else ()) + p.family; + Wserver.wprint "
      \n"; +(* + Wserver.wprint "%s
      \n" (commd conf) + (capitale (transl_nth conf "note/notes" 0)); +*) + trailer conf; + return () +; + +value parents_label conf = + fun + [ 1 -> transl conf "the parents" + | 2 -> transl conf "grand-parents" + | 3 -> transl conf "great-grand-parents" + | n -> + transl conf "ancestors (some)" ^ " " ^ + Printf.sprintf (ftransl conf "of the %s generation") + (transl_nth conf "nth (generation)" n) ] +; + +value ancestor_label conf x sex = + let is = index_of_sex sex in + match x with + [ 1 -> transl_nth conf "the father/the mother/a parent" is + | 2 -> transl_nth conf "a grandfather/a grandmother/a grandparent" is + | 3 -> + transl_nth conf + "a great-grandfather/a great-grandmother/a great-grandparent" is + | n -> + transl_nth conf "an ancestor" is ^ " " ^ + Printf.sprintf (ftransl conf "of the %s generation") + (transl_nth conf "nth (generation)" n) ] +; + +value descendant_label conf x p = + let is = index_of_sex p.sexe in + match x with + [ 1 -> transl_nth conf "a son/a daughter/a child" is + | 2 -> transl_nth conf "a grandson/a granddaughter/a grandchild" is + | 3 -> + transl_nth conf + "a great-grandson/a great-granddaughter/a great-grandchild" is + | n -> + transl_nth conf "a descendant" is ^ " " ^ + Printf.sprintf (ftransl conf "of the %s generation") + (transl_nth conf "nth (generation)" n) ] +; + +value brother_label conf x sex = + let is = index_of_sex sex in + match x with + [ 1 -> transl_nth conf "a brother/a sister/a sibling" is + | 2 -> transl_nth conf "a cousin" is + | 3 -> transl_nth conf "a 2nd cousin" is + | 4 -> transl_nth conf "a 3rd cousin" is + | n -> + Printf.sprintf (ftransl_nth conf "a %s cousin" is) + (transl_nth conf (transl_nth conf "*nth (cousin)*" is) (n - 1)) ] +; + +value uncle_label conf x p = + let is = index_of_sex p.sexe in + match x with + [ 1 -> transl_nth conf "an uncle/an aunt" is + | 2 -> transl_nth conf "a great-uncle/a great-aunt" is + | n -> + transl_nth conf "an uncle/an aunt" is ^ " " ^ + Printf.sprintf (ftransl conf "of the %s generation") + (transl_nth conf "nth (generation)" n) ] +; + +value nephew_label conf x p = + let is = index_of_sex p.sexe in + match x with + [ 1 -> transl_nth conf "a nephew/a niece" is + | 2 -> transl_nth conf "a great-nephew/a great-niece" is + | n -> + transl_nth conf "a nephew/a niece" is ^ " " ^ + Printf.sprintf (ftransl conf "of the %s generation") + (transl_nth conf "nth (generation)" n) ] +; + +value print_link conf base n p1 p2 x1 x2 = + let (p1, x1, p2, x2) = + if p1.sexe <> Neutre then (p1, x1, p2, x2) else (p2, x2, p1, x1) + in + do afficher_personne_sans_titre conf base p1; + afficher_titre conf base p1; + Wserver.wprint " %s" (transl conf "is"); + if n > 1 then Wserver.wprint " %s" (transl conf "also") else (); + Wserver.wprint "\n"; + if x1 == 0 then Wserver.wprint "%s" (ancestor_label conf x2 p1.sexe) + else if x2 == 0 then Wserver.wprint "%s" (descendant_label conf x1 p1) + else if x1 == x2 then Wserver.wprint "%s" (brother_label conf x2 p1.sexe) + else if x1 == 1 || x2 == 1 then + if x1 == 1 then Wserver.wprint "%s" (uncle_label conf (x2 - x1) p1) + else Wserver.wprint "%s" (nephew_label conf (x1 - x2) p1) + else if x1 < x2 then + do Wserver.wprint "%s" (brother_label conf x1 p1.sexe); + Wserver.wprint " %s" + (transl_concat conf "of" (ancestor_label conf (x2 - x1) Neutre)); + return () + else + do Wserver.wprint "%s" (descendant_label conf (x1 - x2) p1); + Wserver.wprint " %s" + (transl_concat conf "of" (brother_label conf x2 Masculin)); + return (); + Wserver.wprint "\n%s " (transl_nth conf "of" 0); + afficher_personne_sans_titre conf base p2; + afficher_titre conf base p2; + Wserver.wprint ".\n"; + return () +; + +value string_of_big_int conf i = + let sep = transl conf "(thousand separator)" in + glop i where rec glop i = + if i == 0 then "" + else + let s = glop (i / 1000) in + if s = "" then string_of_int (i mod 1000) + else s ^ sep ^ Printf.sprintf "%03d" (i mod 1000) +; + +value print_solution_ancestor conf p1 p2 x1 x2 list = + do Wserver.wprint "
        \n"; + List.iter + (fun (a, n) -> + do Wserver.wprint "
      • \n"; + Wserver.wprint "%s %s:\n" (string_of_big_int conf n) + (transl_nth conf "branch/branches" (if n = 1 then 0 else 1)); + Wserver.wprint "%s " (transl conf "click"); + Wserver.wprint + "%s" + (commd conf) (Adef.int_of_iper a.cle_index) x1 + (Adef.int_of_iper p1.cle_index) x2 + (Adef.int_of_iper p2.cle_index) + (transl conf "here"); + if n > 1 then + Wserver.wprint "%s" (transl conf " to see the first branch") + else (); + Wserver.wprint ".\n"; + return ()) + list; + Wserver.wprint "
      \n"; + return () +; + +value print_solution_not_ancestor conf base p1 p2 x1 x2 list = + do Wserver.wprint "
      • \n"; + Wserver.wprint "%s\n" (capitale (transl conf "indeed,")); + Wserver.wprint "\n"; + let is_are = + match list with + [ [_] -> transl conf "is" + | _ -> transl conf "are" ] + in + Wserver.wprint "%s %s\n" is_are (transl conf "at the same time"); + return + let lab x = + match list with + [ [(a, _)] -> ancestor_label conf x a.sexe + | _ -> parents_label conf x ] + in + do Wserver.wprint "
          \n"; + Wserver.wprint "
        • %s %s\n" (lab x1) (transl_nth conf "of" 0); + afficher_personne_sans_titre conf base p1; + afficher_titre conf base p1; + Wserver.wprint "\n"; + Wserver.wprint "
        • %s %s\n" (lab x2) (transl_nth conf "of" 0); + afficher_personne_sans_titre conf base p2; + afficher_titre conf base p2; + Wserver.wprint "\n"; + Wserver.wprint "
        \n"; + Wserver.wprint "
      \n"; + return () +; + +value print_solution conf base n p1 p2 (x1, x2, list) = + do print_link conf base n p2 p1 x2 x1; return + if x1 == 0 || x2 == 0 then print_solution_ancestor conf p1 p2 x1 x2 list + else print_solution_not_ancestor conf base p1 p2 x1 x2 list +; + +value print_propose_upto conf base p1 p2 rl = + match rl with + [ [(x1, x2, _) :: _] when x1 == 0 || x2 == 0 -> + let maxlen = + List.fold_right (fun (x1, x2, _) maxlen -> max maxlen (max x1 x2)) + rl 0 + in + let (p, a) = if x1 == 0 then (p2, p1) else (p1, p2) in + do Wserver.wprint "

      \n%s %s\n" + (capitale (transl conf "ancestors")) + (transl_nth conf "of" 0); + afficher_personne_titre conf base p; + Wserver.wprint " %s\n" (transl conf "up to"); + afficher_personne_titre conf base a; + Wserver.wprint ":\n%s\n" (transl conf "click"); + Wserver.wprint "" + (commd conf) (Adef.int_of_iper p.cle_index) + (Adef.int_of_iper a.cle_index) maxlen; + Wserver.wprint "%s." (transl conf "here"); + Wserver.wprint "\n"; + return () + | _ -> () ] +; + +value round_2_dec x = floor (x *. 100.0 +. 0.5) /. 100.0; + +value print_main_relationship conf base p1 p2 = + let title _ = Wserver.wprint "%s" (capitale (transl conf "relationship")) in + if p1.cle_index == p2.cle_index then + do header conf title; conf.senv := ""; + Wserver.wprint "%s\n" (capitale (transl conf "it is the same person!")); + trailer conf; + return () + else + let _ = base.ascends.array () in + let _ = base.couples.array () in + let tab = Consang.make_relationship_table base in + let (relationship, ancestors) = + Consang.relationship_and_links base tab True p1.cle_index p2.cle_index + in + if ancestors = [] then + do header conf title; + conf.senv := ""; + Wserver.wprint + (fcapitale + (ftransl conf + "no known relationship link between %t and %t")) + (fun _ -> afficher_personne_titre_referencee conf base p1) + (fun _ -> afficher_personne_titre_referencee conf base p2); + Wserver.wprint "\n"; + trailer conf; + return () + else + let total = + List.fold_left + (fun n i -> + let u = tab.Consang.info.(i) in + List.fold_left + (fun n (_, n1) -> + List.fold_left (fun n (_, n2) -> n + n1 * n2) n + u.Consang.lens1) + n u.Consang.lens2) + 0 ancestors + in + let rl = + List.fold_left + (fun rl i -> + let u = tab.Consang.info.(i) in + let p = base.persons.get i in + List.fold_left + (fun rl (len1, n1) -> + List.fold_left + (fun rl (len2, n2) -> + [(len1, len2, (p, n1 * n2)) :: rl]) + rl u.Consang.lens2) + rl u.Consang.lens1) + [] ancestors + in + let rl = + Sort.list + (fun (len11, len12, _) (len21, len22, _) -> + if len11 + len12 > len21 + len22 then True + else if len11 + len12 < len21 + len22 then False + else len11 > len21) + rl + in + let rl = + List.fold_left + (fun l (len1, len2, sol) -> + match l with + [ [(l1, l2, sols) :: l] when len1 == l1 && len2 == l2 -> + [(l1, l2, [sol :: sols]) :: l] + | _ -> [(len1, len2, [sol]) :: l] ]) + [] rl + in + let a1 = aoi base p1.cle_index in + let a2 = aoi base p2.cle_index in + do header conf title; conf.senv := ""; + let _ = + List.fold_left + (fun i sol -> + do print_solution conf base i p1 p2 sol; return succ i) + 1 rl + in + (); + Wserver.wprint "\n"; + Wserver.wprint "

      \n"; + Wserver.wprint "%s: %s %s\n" + (capitale (transl conf "total")) + (string_of_big_int conf total) + (transl_nth conf "relationship link/relationship links" + (if total = 1 then 0 else 1)); + if + age_autorise conf base p1 && age_autorise conf base p2 && + a1.consang != Adef.fix (-1) && a2.consang != Adef.fix (-1) + then + do Wserver.wprint "

      \n%s: " + (capitale (transl conf "consanguinity")); + print_decimal_num conf + (round_2_dec + (Adef.float_of_fix + (Adef.fix_of_float relationship) *. 100.0)); + Wserver.wprint "%%

      \n"; + return () + else (); + print_propose_upto conf base p1 p2 rl; + trailer conf; + return () +; + +value print conf senv base p = + match p_getint senv "i" with + [ Some i -> print_main_relationship conf base (base.persons.get i) p + | _ -> + match find_person_in_env conf base "1" with + [ Some p1 -> print_main_relationship conf base p1 p + | _ -> print_menu conf base p ] ] +; diff --git a/src/relationLink.ml b/src/relationLink.ml new file mode 100644 index 0000000000..e6d0db6c16 --- /dev/null +++ b/src/relationLink.ml @@ -0,0 +1,434 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: relationLink.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +value has_td_width_percent conf = + let user_agent = Wserver.extract_param "user-agent: " '.' conf.request in + String.lowercase user_agent <> "mozilla/1" +; + +value print_someone conf base ip = + let p = poi base ip in + do afficher_personne_titre_referencee conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return () +; + +value rec print_both_branches conf base pl1 pl2 = + if pl1 = [] && pl2 = [] then () + else + let (p1, pl1) = + match pl1 with + [ [(p1, _) :: pl1] -> (Some p1, pl1) + | [] -> (None, []) ] + in + let (p2, pl2) = + match pl2 with + [ [(p2, _) :: pl2] -> (Some p2, pl2) + | [] -> (None, []) ] + in + do tag "tr" begin + stag "td" "align=center" begin + match p1 with + [ Some p1 -> Wserver.wprint "|" + | None -> () ]; + end; + stag "td" "align=center" begin + match p2 with + [ Some p2 -> Wserver.wprint "|" + | None -> () ]; + end; + Wserver.wprint "\n"; + end; + tag "tr" begin + tag "td" "valign=top align=center%s" + (if has_td_width_percent conf then " width=\"50%\"" else "") + begin + match p1 with + [ Some p1 -> print_someone conf base p1 + | None -> () ]; + end; + tag "td" "valign=top align=center%s" + (if has_td_width_percent conf then " width=\"50%\"" else "") + begin + match p2 with + [ Some p2 -> print_someone conf base p2 + | None -> () ]; + end; + end; + return print_both_branches conf base pl1 pl2 +; + +value rec print_one_branch conf base ipl1 = + if ipl1 = [] then () + else + let (ip1, ipl1) = + match ipl1 with + [ [(ip1, _) :: ipl1] -> (Some ip1, ipl1) + | [] -> (None, []) ] + in + do tag "tr" begin + stag "td" "align=center" begin + match ip1 with + [ Some ip1 -> Wserver.wprint "|" + | None -> () ]; + end; + Wserver.wprint "\n"; + end; + tag "tr" begin + tag "td" "align=center" begin + match ip1 with + [ Some ip1 -> print_someone conf base ip1 + | None -> () ]; + end; + end; + return print_one_branch conf base ipl1 +; + +type dist = + { dmin : mutable int; + dmax : mutable int; + mark : bool } +; + +value infinity = 1000; + +value threshold = ref 15; + +value leq = ref (fun []); +module Pq = + Pqueue.Make (struct type t = int; value leq x y = leq.val x y; end) +; + +value make_dist_tab base ia maxlev = + if maxlev <= threshold.val then + (fun _ -> 0, fun _ -> infinity) + else + let _ = base.ascends.array () in + let _ = base.couples.array () in + let id = Consang.topological_sort base in + let default = {dmin = infinity; dmax = 0; mark = False} in + let dist = Array.create base.persons.len default in + do leq.val := fun x y -> id.(x) > id.(y); return + let q = ref Pq.empty in + let add_children ip = + let p = poi base ip in + for i = 0 to Array.length p.family - 1 do + let fam = foi base p.family.(i) in + for j = 0 to Array.length fam.children - 1 do + let k = Adef.int_of_iper fam.children.(j) in + let d = dist.(k) in + if not d.mark then + do dist.(k) := {dmin = infinity; dmax = 0; mark = True}; + q.val := Pq.add k q.val; + return () + else (); + done; + done + in + do dist.(Adef.int_of_iper ia) := {dmin = 0; dmax = 0; mark = True}; + add_children ia; + while not (Pq.is_empty q.val) do + let (k, nq) = Pq.take q.val in + do q.val := nq; return + match (base.ascends.get k).parents with + [ Some ifam -> + let cpl = coi base ifam in + let dfath = dist.(Adef.int_of_iper cpl.father) in + let dmoth = dist.(Adef.int_of_iper cpl.mother) in + do dist.(k).dmin := min dfath.dmin dmoth.dmin + 1; + dist.(k).dmax := max dfath.dmax dmoth.dmax + 1; + if dist.(k).dmin > maxlev then () + else add_children (Adef.iper_of_int k); + return () + | None -> () ]; + done; + return + (fun ip -> dist.(Adef.int_of_iper ip).dmin, + fun ip -> dist.(Adef.int_of_iper ip).dmax) +; + +value find_first_branch base (dmin, dmax) ia = + find [] where rec find br len ip sp = + if ip == ia then if len == 0 then Some br else None + else if len == 0 then None + else + if len < dmin ip || len > dmax ip then None + else + match (aoi base ip).parents with + [ Some ifam -> + let cpl = coi base ifam in + match find [(ip, sp) :: br] (len - 1) cpl.father Masculin with + [ Some _ as r -> r + | None -> find [(ip, sp) :: br] (len - 1) cpl.mother Feminin ] + | None -> None ] +; + +value branch_of_num base ip n = + let rec expand bl n = + if Num.eq n Num.one then bl else expand [Num.even n :: bl] (Num.half n) + in + let rec loop ipl ip sp = + fun + [ [] -> [(ip, sp) :: ipl] + | [goto_fath :: nl] -> + match (aoi base ip).parents with + [ Some ifam -> + let cpl = coi base ifam in + if goto_fath then loop [(ip, sp) :: ipl] cpl.father Masculin nl + else loop [(ip, sp) :: ipl] cpl.mother Feminin nl + | _ -> [(ip, sp) :: ipl] ] ] + in + loop [] ip (poi base ip).sexe (expand [] n) +; + +value num_of_branch ia sa ipl = + let ipl = List.tl (List.rev [(ia, sa) :: ipl]) in + List.fold_left + (fun b (ip, sp) -> + let b = Num.twice b in + match sp with + [ Masculin -> b + | Feminin -> Num.inc b 1 + | Neutre -> assert False ]) + Num.one ipl +; + +value rec next_branch_same_len base dist backward missing ia sa ipl = + if backward then + match ipl with + [ [] -> None + | [(ip, sp) :: ipl1] -> + match sa with + [ Feminin -> + next_branch_same_len base dist True (missing + 1) ip sp ipl1 + | Masculin -> + match (aoi base ip).parents with + [ Some ifam -> + let cpl = coi base ifam in + next_branch_same_len base dist False missing cpl.mother + Feminin ipl + | _ -> failwith "next_branch_same_len" ] + | Neutre -> assert False ] ] + else if missing == 0 then Some (ia, sa, ipl) + else if missing < fst dist ia || missing > snd dist ia then + next_branch_same_len base dist True missing ia sa ipl + else + match (aoi base ia).parents with + [ Some ifam -> + let cpl = coi base ifam in + next_branch_same_len base dist False (missing - 1) cpl.father Masculin + [(ia, sa) :: ipl] + | None -> next_branch_same_len base dist True missing ia sa ipl ] +; + +value text_of_sex = + fun + [ Masculin -> "Masculin" + | Feminin -> "Feminin" + | Neutre -> "Neutre" ] +; + +value find_next_branch base dist ia sa ipl = + loop ia sa ipl where rec loop ia1 sa1 ipl = + match next_branch_same_len base dist True 0 ia1 sa1 ipl with + [ Some (ia1, sa1, ipl) -> if ia == ia1 then Some ipl else loop ia1 sa1 ipl + | _ -> None ] +; + +value rec prev_branch_same_len base dist backward missing ia sa ipl = + if backward then + match ipl with + [ [] -> None + | [(ip, sp) :: ipl1] -> + match sa with + [ Masculin -> + prev_branch_same_len base dist True (missing + 1) ip sp ipl1 + | Feminin -> + match (aoi base ip).parents with + [ Some ifam -> + let cpl = coi base ifam in + prev_branch_same_len base dist False missing cpl.father + Masculin ipl + | _ -> failwith "prev_branch_same_len" ] + | Neutre -> assert False ] ] + else if missing == 0 then Some (ia, sa, ipl) + else if missing < fst dist ia || missing > snd dist ia then + prev_branch_same_len base dist True missing ia sa ipl + else + match (aoi base ia).parents with + [ Some ifam -> + let cpl = coi base ifam in + prev_branch_same_len base dist False (missing - 1) cpl.mother Feminin + [(ia, sa) :: ipl] + | None -> prev_branch_same_len base dist True missing ia sa ipl ] +; + +value find_prev_branch base dist ia sa ipl = + loop ia sa ipl where rec loop ia1 sa1 ipl = + match prev_branch_same_len base dist True 0 ia1 sa1 ipl with + [ Some (ia1, sa1, ipl) -> if ia == ia1 then Some ipl else loop ia1 sa1 ipl + | _ -> None ] +; + +value print_sign conf sign ip sp i1 i2 b1 b2 c1 c2 = + do Wserver.wprint "%s" sign; + Wserver.wprint "\n"; + return () +; + +value print_prev_next conf base ip sp i1 i2 b1 b2 c1 c2 pb1 pb2 nb1 nb2 = + tag "tr" begin + if b1 <> [] then + tag "td" begin + Wserver.wprint "
      \n"; + match pb1 with + [ Some b1 -> print_sign conf "<<" ip sp i1 i2 b1 b2 (c1 - 1) c2 + | _ -> () ]; + match (pb1, nb1) with + [ (None, None) -> () + | _ -> Wserver.wprint "%d\n" c1 ]; + match nb1 with + [ Some b1 -> print_sign conf ">>" ip sp i1 i2 b1 b2 (c1 + 1) c2 + | _ -> () ]; + end + else (); + if b2 <> [] then + tag "td" begin + Wserver.wprint "
      \n"; + match pb2 with + [ Some b2 -> print_sign conf "<<" ip sp i1 i2 b1 b2 c1 (c2 - 1) + | _ -> () ]; + match (pb2, nb2) with + [ (None, None) -> () + | _ -> Wserver.wprint "%d\n" c2 ]; + match nb2 with + [ Some b2 -> print_sign conf ">>" ip sp i1 i2 b1 b2 c1 (c2 + 1) + | _ -> () ]; + end + else (); + end +; + +value print_relation conf base ip1 ip2 = + let params = + let po = find_person_in_env conf base "" in + match (po, p_getint conf.env "l1", p_getint conf.env "l2") with + [ (Some p, Some l1, Some l2) -> + let ip = p.cle_index in + let dist = make_dist_tab base ip (max l1 l2 + 1) in + let b1 = find_first_branch base dist ip l1 ip1 Neutre in + let b2 = find_first_branch base dist ip l2 ip2 Neutre in + Some (ip, (poi base ip).sexe, dist, b1, b2, 1, 1) + | _ -> + match + (p_getenv conf.env "b1", p_getenv conf.env "b2", + p_getint conf.env "c1", p_getint conf.env "c2") + with + [ (Some b1str, Some b2str, Some c1, Some c2) -> + let n1 = Num.of_string b1str in + let n2 = Num.of_string b2str in + match (branch_of_num base ip1 n1, branch_of_num base ip2 n2) with + [ ([(ia1, sa1) :: b1], [(ia2, sa2) :: b2]) -> + if ia1 == ia2 then + let dist = + let maxlev = max (List.length b1) (List.length b2) + 1 in + make_dist_tab base ia1 maxlev + in + Some (ia1, sa1, dist, Some b1, Some b2, c1, c2) + else None + | _ -> None ] + | _ -> None ] ] + in + match params with + [ Some (ip, sp, dist, Some b1, Some b2, c1, c2) -> + let pb1 = + if c1 == 1 then None else find_prev_branch base dist ip sp b1 + in + let nb1 = find_next_branch base dist ip sp b1 in + let pb2 = + if c2 == 1 then None else find_prev_branch base dist ip sp b2 + in + let nb2 = find_next_branch base dist ip sp b2 in + let title _ = + do Wserver.wprint "Lien de parenté"; + match (pb1, nb1) with + [ (None, None) -> () + | _ -> Wserver.wprint " %d" c1 ]; + match (pb2, nb2) with + [ (None, None) -> () + | _ -> Wserver.wprint " %d" c2 ]; + return () + in + do Util.html conf; + Wserver.wprint "\ +\n"; + tag "head" begin + Wserver.wprint " \n"; + Wserver.wprint " "; + title True; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (try " " ^ List.assoc "body_prop" conf.base_env with + [ Not_found -> "" ]); + tag "table" "cellspacing=0 cellpadding=0 width=\"100%%\"" begin + if b1 = [] || b2 = [] then + let b = if b1 = [] then b2 else b1 in + do tag "tr" begin + stag "td" "align=center" begin + print_someone conf base ip; + end; + end; + print_one_branch conf base b; + return () + else + do tag "tr" begin + stag "td" "colspan=2 align=center" begin + print_someone conf base ip; + end; + end; + tag "tr" begin + stag "td" "colspan=2 align=center" begin + Wserver.wprint "|"; + end; + end; + tag "tr" begin + stag "td" "colspan=2 align=center" begin + Wserver.wprint "

      " + (if has_td_width_percent conf then " width=\"50%\"" + else ""); + end; + end; + print_both_branches conf base b1 b2; + return (); + print_prev_next conf base ip sp ip1 ip2 b1 b2 c1 c2 pb1 pb2 nb1 nb2; + end; + trailer conf; + return () + | _ -> + let title _ = Wserver.wprint "Paramètres erronés" in + do header conf title; + trailer conf; + return () ] +; + +value print conf base = + match + (find_person_in_env conf base "1", find_person_in_env conf base "2") + with + [ (Some p1, Some p2) -> print_relation conf base p1.cle_index p2.cle_index + | _ -> incorrect_request conf ] +; diff --git a/src/select.ml b/src/select.ml new file mode 100644 index 0000000000..04a7b82ca2 --- /dev/null +++ b/src/select.ml @@ -0,0 +1,71 @@ +(* $Id: select.ml,v 1.1 1998-09-01 14:32:11 ddr Exp $ *) + +open Def; +open Gutil; + +value select_ancestors base per_tab fam_tab flag = + loop where rec loop iper = + let i = Adef.int_of_iper iper in + if per_tab.(i) land flag <> 0 then () + else + do per_tab.(i) := per_tab.(i) lor flag; return + match (aoi base iper).parents with + [ Some ifam -> + let i = Adef.int_of_ifam ifam in + if fam_tab.(i) land flag <> 0 then () + else + do fam_tab.(i) := fam_tab.(i) lor flag; return + let cpl = coi base ifam in + do loop cpl.father; + loop cpl.mother; + return () + | None -> () ] +; + +value select_descendants base per_tab fam_tab flag = + loop where rec loop iper = + let i = Adef.int_of_iper iper in + if per_tab.(i) land flag <> 0 then () + else + do per_tab.(i) := per_tab.(i) lor flag; return + Array.iter + (fun ifam -> + let i = Adef.int_of_ifam ifam in + if fam_tab.(i) land flag <> 0 then () + else + let fam = foi base ifam in + let cpl = coi base ifam in + do fam_tab.(i) := fam_tab.(i) lor flag; + let i = Adef.int_of_iper cpl.father in + per_tab.(i) := per_tab.(i) lor flag; + let i = Adef.int_of_iper cpl.mother in + per_tab.(i) := per_tab.(i) lor flag; + return + Array.iter loop (foi base ifam).children) + (poi base iper).family +; + +value functions base anc desc = + match (anc, desc) with + [ (None, None) -> (fun _ -> True, fun _ -> True) + | _ -> + let per_tab = Array.create base.persons.len 0 in + let fam_tab = Array.create base.families.len 0 in + match (anc, desc) with + [ (Some iaper, None) -> + do select_ancestors base per_tab fam_tab 1 iaper; return + (fun i -> per_tab.(Adef.int_of_iper i) == 1, + fun i -> fam_tab.(Adef.int_of_ifam i) == 1) + | (None, Some idper) -> + do select_descendants base per_tab fam_tab 1 idper; return + (fun i -> per_tab.(Adef.int_of_iper i) == 1, + fun i -> fam_tab.(Adef.int_of_ifam i) == 1) + | (Some iaper, Some idper) -> + do select_ancestors base per_tab fam_tab 1 iaper; + select_descendants base per_tab fam_tab 2 idper; + return + (fun i -> per_tab.(Adef.int_of_iper i) == 3, + fun i -> fam_tab.(Adef.int_of_ifam i) == 3) + | _ -> assert False ] ] + +; diff --git a/src/some.ml b/src/some.ml new file mode 100644 index 0000000000..0cc8f40efd --- /dev/null +++ b/src/some.ml @@ -0,0 +1,443 @@ +(* camlp4r ./def.syn.cmo *) +(* $Id: some.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Gutil; +open Config; +open Util; + +value first_name_not_found conf x = + let title _ = + Wserver.wprint "%s: \"%s\"" + (capitale (transl conf "first name not found")) x + in + do header conf title; trailer conf; return () +; + +value surname_not_found conf x = + let title _ = + Wserver.wprint "%s: \"%s\"" (capitale (transl conf "surname not found")) x + in + do header conf title; trailer conf; return () +; + +value persons_of_fsname base find proj x = + let istrl = base.strings_of_fsname x in + let l = + let x = Name.crush_lower x in + List.fold_right + (fun istr l -> + let str = sou base istr in + if Name.crush_lower str = x then + let iperl = find istr in + let iperl = + List.fold_left + (fun iperl iper -> + if proj (poi base iper) = istr then [iper :: iperl] + else iperl) + [] iperl + in + if iperl = [] then l else [(str, istr, iperl) :: l] + else l) + istrl [] + in + let (l, name_inj) = + let (l1, name_inj) = + let x = Name.lower x in + (List.fold_right + (fun (str, istr, iperl) l -> + if x = Name.lower str then [(str, istr, iperl) :: l] else l) + l [], + Name.lower) + in + let (l1, name_inj) = + if l1 = [] then + let x = Name.strip_lower x in + (List.fold_right + (fun (str, istr, iperl) l -> + if x = Name.strip_lower str then [(str, istr, iperl) :: l] + else l) + l [], + Name.strip_lower) + else (l1, name_inj) + in + if l1 = [] then (l, Name.crush_lower) else (l1, name_inj) + in + (l, name_inj) +; + +value print_elem conf base is_surname (p, xl) = + match xl with + [ [x] -> + do Wserver.wprint "" (commd conf) (acces conf base x); + if is_surname then + Wserver.wprint "%s%s" (surname_end p) (surname_begin p) + else Wserver.wprint "%s" p; + Wserver.wprint "\n"; + Date.afficher_dates_courtes conf base x; + return () + | _ -> + let _ = + List.fold_left + (fun first x -> + do if not first then Wserver.wprint "
    • " else (); + Wserver.wprint "" (commd conf) + (acces conf base x); + if is_surname then + Wserver.wprint "%s%s" (surname_end p) (surname_begin p) + else Wserver.wprint "%s" p; + Wserver.wprint ""; + Date.afficher_dates_courtes conf base x; + Wserver.wprint " "; + preciser_homonyme conf base x; + Wserver.wprint "\n"; + return False) + True xl + in + () ] +; + +value first_name_print_list conf base xl liste = + let liste = + let l = + Sort.list + (fun x1 x2 -> + match alphabetique (sou base x1.surname) (sou base x2.surname) with + [ 0 -> + match + (Adef.od_of_codate x1.birth, Adef.od_of_codate x2.birth) + with + [ (Some d1, Some d2) -> d1 strictement_apres d2 + | (Some d1, _) -> False + | _ -> True ] + | n -> n > 0 ]) + liste + in + List.fold_left + (fun l x -> + let px = sou base x.surname in + match l with + [ [(p, l1) :: l] when alphabetique px p == 0 -> [(p, [x :: l1]) :: l] + | _ -> [(px, [x]) :: l] ]) + [] l + in + let title _ = + do Wserver.wprint "%s" (List.hd xl); + List.iter (fun x -> Wserver.wprint ", %s" x) (List.tl xl); + return () + in + do header conf title; + print_alphab_list (fun (p, _) -> String.sub p (initiale p) 1) + (print_elem conf base True) liste; + trailer conf; + return () +; + +value select_first_name conf base n list = + let title _ = + Wserver.wprint "%s \"%s\" : %s" + (capitale (transl_nth conf "first name/first names" 0)) n + (transl conf "specify") + in + do header conf title; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value rec merge_insert ((sstr, (strl, iperl)) as x) = + fun + [ [((sstr1, (strl1, iperl1)) as y) :: l] -> + if sstr < sstr1 then [x; y :: l] + else if sstr > sstr1 then [y :: merge_insert x l] + else [(sstr, (strl @ strl1, iperl @ iperl1)) :: l] + | [] -> [x] ] +; + +value first_name_print conf base x = + let (list, _) = + persons_of_fsname base base.persons_of_first_name.find + (fun x -> x.first_name) x + in + let list = + List.map (fun (str, istr, iperl) -> (Name.strip_lower str, ([str], iperl))) + list + in + let list = List.fold_right merge_insert list [] in + match list with + [ [] -> first_name_not_found conf x + | [(_, (strl, iperl))] -> + first_name_print_list conf base strl (List.map (poi base) iperl) + | _ -> select_first_name conf base x list ] +; + +value she_has_children_with_her_name base wife husband children = + let wife_surname = Name.strip_lower (sou base wife.surname) in + if Name.strip_lower (sou base husband.surname) = wife_surname then + False + else + List.exists + (fun c -> + Name.strip_lower (sou base (poi base c).surname) = wife_surname) + (Array.to_list children) +; + +value afficher_date_mariage conf base p c dmar = + if age_autorise conf base p && age_autorise conf base c then + match dmar with + [ Some d -> + do Wserver.wprint ""; + Date.display_year d; + Wserver.wprint ""; + return () + | None -> () ] + else () +; + +value max_lev = 3; + +value rec print_branch conf base lev name p = + do Wserver.wprint "%s" (if lev == 0 then "
      \n" else "
    • "); + Wserver.wprint ""; + if sou base p.surname = name then + afficher_prenom_de_personne_referencee conf base p + else afficher_personne_referencee conf base p; + Wserver.wprint ""; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return + if Array.length p.family == 0 then () + else + let _ = List.fold_left + (fun (first, need_br) ifam -> + let fam = foi base ifam in + let dmar = Adef.od_of_codate fam.marriage in + let c = conjoint p (coi base ifam) in + let el = fam.children in + let c = poi base c in + do if need_br then Wserver.wprint "
      \n" else (); + if not first then + do Wserver.wprint ""; + if sou base p.surname = name then + afficher_prenom_de_personne conf base p + else afficher_personne conf base p; + Wserver.wprint ""; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return () + else (); + Wserver.wprint " &"; + afficher_date_mariage conf base p c dmar; + Wserver.wprint " "; + afficher_personne_referencee conf base c; + Wserver.wprint ""; + Date.afficher_dates_courtes conf base c; + Wserver.wprint "\n"; + return + let down = + p.sexe = Masculin && + (Name.strip_lower (sou base p.surname) = Name.strip_lower name + || lev == 0) && + Array.length el <> 0 || + p.sexe = Feminin && she_has_children_with_her_name base p c el + in + if down then + do Wserver.wprint "
        \n"; + List.iter + (fun e -> print_branch conf base (succ lev) name (poi base e)) + (Array.to_list el); + Wserver.wprint "
      \n"; + return (False, not down) + else (False, not down)) + (True, False) (Array.to_list p.family) + in () +; + +value rec print_by_branch x conf base (ipl, homonymes) = + let l = List.map (poi base) ipl in + let ancestors = + Sort.list + (fun p1 p2 -> + alphabetique (sou base p1.first_name) (sou base p2.first_name) <= 0) + l + in + let len = List.length ancestors in + if len == 0 then surname_not_found conf x + else + let x = List.hd homonymes in + let title h = + do Wserver.wprint "%s" (List.hd homonymes); + List.iter (fun x -> Wserver.wprint ", %s" x) (List.tl homonymes); + return () + in + do header conf title; + Wserver.wprint "\n"; + Wserver.wprint "%s " (capitale (transl conf "click")); + Wserver.wprint "%s\n" (commd conf) + (if conf.senv = "" then "" else "e=" ^ conf.senv ^ ";") + (code_varenv x) + (transl conf "here"); + Wserver.wprint "%s" + (transl conf "for the first names by alphabetic order"); + Wserver.wprint ".\n

      \n"; + Wserver.wprint "\n"; + if len > 1 then + Wserver.wprint "%s: %d

      \n

        \n" + (capitale (transl conf "number of branches")) len + else (); + let _ = List.fold_left + (fun n p -> + do if len > 1 then Wserver.wprint "
      1. \n" else (); + print_branch conf base 0 x p; + return n + 1) + 1 ancestors + in (); + if len > 1 then Wserver.wprint "
      \n" else (); + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_family_alphabetic x conf base liste = + let liste = + let l = + Sort.list + (fun x1 x2 -> + match + alphabetique (sou base x1.first_name) (sou base x2.first_name) + with + [ 0 -> x1.occ > x2.occ + | n -> n > 0 ]) + liste + in + List.fold_left + (fun l x -> + let px = sou base x.first_name in + match l with + [ [(p, l1) :: l] when alphabetique px p == 0 -> [(p, [x :: l1]) :: l] + | _ -> [(px, [x]) :: l] ]) + [] l + in + match liste with + [ [] -> surname_not_found conf x + | _ -> + let title _ = Wserver.wprint "%s" x in + do header conf title; + print_alphab_list (fun (p, _) -> String.sub p (initiale p) 1) + (print_elem conf base False) liste; + trailer conf; + return () ] +; + +value has_at_least_2_children_with_surname base fam surname = + loop 0 0 where rec loop cnt i = + if i == Array.length fam.children then False + else + let p = poi base fam.children.(i) in + if p.surname == surname then + if cnt == 1 then True + else loop (cnt + 1) (i + 1) + else loop cnt (i + 1) +; + +value select_ancestors base name_inj ipl = + let str_inj s = name_inj (sou base s) in + List.fold_left + (fun ipl ip -> + let p = poi base ip in + let a = aoi base ip in + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + let fath = poi base cpl.father in + let moth = poi base cpl.mother in + let s = str_inj p.surname in + if str_inj fath.surname <> s && str_inj moth.surname <> s + && not (List.memq ip ipl) then + if List.memq cpl.father ipl then ipl + else if + has_at_least_2_children_with_surname base (foi base ifam) + p.surname + then [cpl.father :: ipl] + else [ip :: ipl] + else ipl + | _ -> [ip :: ipl] ]) + [] ipl +; + +value surname_print conf base x = + let (l, name_inj) = + persons_of_fsname base base.persons_of_surname.find (fun x -> x.surname) x + in + let (iperl, strl) = + List.fold_right + (fun (str, istr, iperl1) (iperl, strl) -> + (iperl1 @ iperl, [str :: strl])) + l ([], []) + in + match p_getenv conf.env "o" with + [ Some "i" -> + let liste = + List.fold_right (fun ip ipl -> [poi base ip :: ipl]) iperl [] + in + print_family_alphabetic x conf base liste + | _ -> + let iperl = select_ancestors base name_inj iperl in + print_by_branch x conf base (iperl, strl) ] +; + +value name_print conf base p k = + let liste = + Sort.list + (fun ip1 ip2 -> + let p1 = poi base ip1 in + let p2 = poi base ip2 in + match (Adef.od_of_codate p1.birth, Adef.od_of_codate p2.birth) with + [ (Some d1, Some d2) -> d1 strictement_avant d2 + | (Some d1, _) -> False + | _ -> True ]) + (List.fold_right + (fun ip ipl -> + if not (List.memq ip ipl) then [ip :: ipl] else ipl) + (person_ht_find_all base + (sou base p.first_name ^ " " ^ sou base p.surname)) + []) + in + match liste with + [ [p] -> k p + | liste -> + let title _ = + Wserver.wprint "%s %s : précisez" (sou base p.first_name) + (sou base p.surname) + in + do header conf title; + Wserver.wprint "\n"; + trailer conf; + return () ] +; diff --git a/src/srcfile.ml b/src/srcfile.ml new file mode 100644 index 0000000000..90138949da --- /dev/null +++ b/src/srcfile.ml @@ -0,0 +1,242 @@ +(* camlp4r ./pa_lock.cmo pa_extend.cmo *) +(* $Id: srcfile.ml,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Config; +open Def; +open Util; + +value get_date () = + let tm = Unix.localtime (Unix.time ()) in + Printf.sprintf "%02d/%02d/%d" tm.Unix.tm_mday + (succ tm.Unix.tm_mon) (tm.Unix.tm_year + 1900) +; + +value cnt conf ext = + List.fold_right Filename.concat ["cnt"] (conf.bname ^ ext) +; + +value count conf = + let fname = cnt conf ".txt" in + try + let ic = open_in fname in + let rd = + try + let wc = int_of_string (input_line ic) in + let rc = int_of_string (input_line ic) in + let d = input_line ic in + (wc, rc, d) + with _ -> (0, 0, get_date ()) + in + do close_in ic; return rd + with _ -> + (0, 0, get_date ()) +; + +value write_counter conf (welcome_cnt, request_cnt, start_date) = + let fname = cnt conf ".txt" in + try + let oc = open_out_bin fname in + do output_string oc (string_of_int welcome_cnt); + output_string oc "\n"; + output_string oc (string_of_int request_cnt); + output_string oc "\n"; + output_string oc start_date; + output_string oc "\n"; + close_out oc; + return () + with _ -> + () +; + +value incr_welcome_counter conf = + let lname = cnt conf ".lck" in + lock_wait lname with + [ Accept -> + let (welcome_cnt, request_cnt, start_date) = count conf in + write_counter conf (welcome_cnt + 1, request_cnt, start_date) + | Refuse -> () ] +; + +value incr_request_counter conf = + let lname = cnt conf ".lck" in + lock_wait lname with + [ Accept -> + let (welcome_cnt, request_cnt, start_date) = count conf in + write_counter conf (welcome_cnt, request_cnt + 1, start_date) + | Refuse -> () ] +; + +value hidden_env conf = + List.iter + (fun (k, v) -> Wserver.wprint "\n" k v) + conf.henv +; + +value lang_file_name conf fname = + let fname = + List.fold_right Filename.concat [Util.base_dir.val; "lang"; conf.lang] + (Filename.basename fname ^ ".txt") + in + if Sys.file_exists fname then fname + else + List.fold_right Filename.concat [Util.lang_dir.val; "lang"; conf.lang] + (Filename.basename fname ^ ".txt") +; + +value any_lang_file_name fname = + let fname = + List.fold_right Filename.concat [Util.lang_dir.val; "lang"] + (Filename.basename fname ^ ".txt") + in + if Sys.file_exists fname then fname + else + List.fold_right Filename.concat [Util.base_dir.val; "lang"] + (Filename.basename fname ^ ".txt") +; + +value digit = + fun + [ '0'..'9' as c -> Char.code c - Char.code '0' + | _ -> failwith "digit" ] +; + +module G = Grammar.Make (struct value lexer = Plexer.make (); end); +value date = G.Entry.create "date"; +GEXTEND G + date: + [ [ d = INT; "/"; m = INT; "/"; y = INT; EOI -> + (int_of_string d, int_of_string m, int_of_string y) ] ]; +END; + +value extract_date d = + try Some (G.Entry.parse date (G.parsable (Stream.of_string d))) with + [ Stdpp.Exc_located _ (Stream.Error _ | Token.Error _) -> None ] +; + +value print_date conf = + let (wc, rc, d) = count conf in + match extract_date d with + [ Some (d, m, y) -> + Wserver.wprint "%s" (Date.string_of_date conf (Djma d m y)) + | _ -> Wserver.wprint "%s" d ] +; + +value src_translate conf ic = + let (upp, s) = + loop "" (input_char ic) where rec loop s c = + if c = ']' then + if String.length s > 0 && s.[0] == '*' then + (True, String.sub s 1 (String.length s - 1)) + else (False, s) + else loop (s ^ String.make 1 c) (input_char ic) + in + let r = + match input_char ic with + [ '0'..'9' as c -> Util.transl_nth conf s (Char.code c - Char.code '0') + | c -> Util.transl_nth conf s 0 ^ String.make 1 c ] + in + if upp then capitale r else r +; + +value rec copy_from_channel conf base ic = + let echo = ref True in + try + while True do + match input_char ic with + [ '[' -> + let s = src_translate conf ic in + if not echo.val then () + else Wserver.wprint "%s" s + | '%' -> + let c = input_char ic in + if not echo.val then + if c == 'w' || c == 'x' then echo.val := True else () + else + match c with + [ '%' -> Wserver.wprint "%%" + | '[' | ']' -> Wserver.wprint "%c" c + | 'b' -> + try + Wserver.wprint " %s" (List.assoc "body_prop" conf.base_env) + with [ Not_found -> () ] + | 'c' -> + let (wc, rc, d) = count conf in + Wserver.wprint "%d" wc + | 'd' -> print_date conf + | 'f' -> Wserver.wprint "%s" conf.command + | 'g' -> + do Wserver.wprint "%s?" conf.command; + if conf.cgi then Wserver.wprint "b=%s;" conf.bname else (); + return () + | 'h' -> hidden_env conf + | 'l' -> Wserver.wprint "%s" conf.lang + | 'n' -> Wserver.wprint "%d" (base.persons.len) + | 'q' -> + let (wc, rc, d) = count conf in + Wserver.wprint "%d" (wc + rc) + | 'r' -> copy_from_file conf base (input_line ic) + | 's' -> + do Wserver.wprint "%s?" conf.command; + List.iter (fun (k, v) -> Wserver.wprint "%s=%s;" k v) + conf.henv; + return () + | 't' -> Wserver.wprint "%s" conf.bname + | 'v' -> Wserver.wprint "%s" Util.version + | 'w' -> if not conf.wizard then echo.val := False else () + | 'x' -> + if not (conf.wizard || conf.friend) then echo.val := False + else () + | c -> Wserver.wprint "%%%c" c ] + | c -> if echo.val then Wserver.wprint "%c" c else () ]; + done + with + [ End_of_file -> close_in ic ] +and copy_from_file conf base fname = + let fname = any_lang_file_name fname in + let ic = open_in fname in + copy_from_channel conf base ic +; + +value print conf base fname = + match + try Some (open_in (lang_file_name conf fname)) with + [ Sys_error _ -> + try Some (open_in (any_lang_file_name fname)) with + [ Sys_error _ -> None ] ] + with + [ Some ic -> + do Util.html conf; + copy_from_channel conf base ic; + Util.trailer conf; + return () + | _ -> + let title _ = Wserver.wprint "Error" in + do Util.header conf title; + Wserver.wprint "
      • \n"; + Wserver.wprint "Cannot access file \"%s.txt\".\n" fname; + Wserver.wprint "
      \n"; + Util.trailer conf; + return raise Exit ] +; + +value print_start conf base = + let fname = + if Sys.file_exists (lang_file_name conf conf.bname) then conf.bname + else "start" + in + print conf base fname +; + +value print_lexicon conf base = + let title _ = Wserver.wprint "Lexicon" in + let fname = any_lang_file_name "lexicon" in + let ic = open_in fname in + do Util.header conf title; + Wserver.wprint "
      \n";
+     try while True do Wserver.wprint "%s\n" (input_line ic); done with
+     [ End_of_file -> () ];
+     Wserver.wprint "
      \n"; + close_in ic; + Util.trailer conf; + return () +; diff --git a/src/srcfile.mli b/src/srcfile.mli new file mode 100644 index 0000000000..54742898dd --- /dev/null +++ b/src/srcfile.mli @@ -0,0 +1,9 @@ +(* $Id: srcfile.mli,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +value print : Config.config -> Def.base -> string -> unit; +value print_start : Config.config -> Def.base -> unit; +value incr_welcome_counter : Config.config -> unit; +value incr_request_counter : Config.config -> unit; +value hidden_env : Config.config -> unit; + +value print_lexicon : Config.config -> Def.base -> unit; diff --git a/src/title.ml b/src/title.ml new file mode 100644 index 0000000000..2437373ac4 --- /dev/null +++ b/src/title.ml @@ -0,0 +1,399 @@ +(* camlp4r ./def.syn.cmo *) +(* $Id: title.ml,v 1.1 1998-09-01 14:32:08 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +type date_search = [ JustSelf | AddSpouse | AddChildren ]; + +value infinity = 10000; + +value date_interval conf base t x = + let d1 = ref (Da Sure infinity) in + let d2 = ref (Da Sure 0) in + let found = ref False in + do let rec loop t x = + let set d = + do if d strictement_avant d1.val then d1.val := d else (); + if d strictement_apres d2.val then d2.val := d else (); + found.val := True; + return () + in + do match Adef.od_of_codate x.birth with + [ Some d -> set d + | _ -> () ]; + match x.death with + [ Death _ d -> set (Adef.date_of_cdate d) + | NotDead -> set conf.today + | _ -> () ]; + List.iter + (fun t -> + do match Adef.od_of_codate t.t_date_start with + [ Some d -> set d + | None -> () ]; + match Adef.od_of_codate t.t_date_end with + [ Some d -> set d + | None -> () ]; + return ()) + x.titles; + match t with + [ JustSelf -> () + | _ -> + Array.iter + (fun ifam -> + let fam = foi base ifam in + let md = fam.marriage in + let conj = conjoint x (coi base ifam) in + do match Adef.od_of_codate md with + [ Some d -> set d + | None -> () ]; + loop JustSelf (poi base conj); + match t with + [ AddChildren -> + Array.iter (fun e -> loop JustSelf (poi base e)) + fam.children + | _ -> () ]; + return ()) + x.family ]; + return () + in + loop t x; + return if found.val then Some (d1.val, d2.val) else None +; + +value compare_title_dates conf base (x1, t1) (x2, t2) = + match + ((x1.birth, Adef.od_of_codate t1.t_date_start, + Adef.od_of_codate t1.t_date_end, x1.death), + (x2.birth, Adef.od_of_codate t2.t_date_start, + Adef.od_of_codate t2.t_date_end, x2.death)) + with + [ ((_, Some d1, _, _), (_, Some d2, _, _)) -> + if d1 strictement_avant d2 then True + else if annee d1 == annee d2 then + match + (Adef.od_of_codate t1.t_date_end, + Adef.od_of_codate t2.t_date_end) + with + [ (Some d1, Some d2) -> d1 avant d2 + | _ -> True ] + else False + | ((_, _, Some d1, _), (_, _, Some d2, _)) -> d2 apres d1 + | ((_, _, _, Death _ d1), (_, Some d2, _, _)) + when not (d2 strictement_avant Adef.date_of_cdate d1) -> + True + | ((_, Some d1, _, _), (_, _, _, Death _ d2)) + when not (d1 strictement_avant Adef.date_of_cdate d2) -> + False + | _ -> + match + (date_interval conf base JustSelf x1, + date_interval conf base JustSelf x2) + with + [ (Some (d11, d12), Some (d21, d22)) -> + if d21 apres d12 then True + else if d11 apres d22 then False + else d21 apres d11 + | _ -> + match + (date_interval conf base AddSpouse x1, + date_interval conf base AddSpouse x2) + with + [ (Some (d11, d12), Some (d21, d22)) -> + if not (d21 strictement_avant d12) then True + else if not (d11 strictement_avant d22) then False + else not (d22 strictement_avant d12) + | _ -> + match + (date_interval conf base AddChildren x1, + date_interval conf base AddChildren x2) + with + [ (Some (d11, d12), Some (d21, d22)) -> + if not (d21 strictement_avant d12) then True + else if not (d11 strictement_avant d22) then False + else not (d22 strictement_avant d12) + | (Some _, None) -> True + | (None, Some _) -> False + | (None, None) -> True ] ] ] ] +; + +value compare_places p1 p2 = alphabetique p1 p2 <= 0; + +value compare_titles t1 t2 = t1 <= t2; + +value strip_abbrev_lower s = Name.strip (Name.abbrev (Name.lower s)); + +value select_title_place conf base title place = + let list = ref [] in + let clean_title = ref title in + let clean_place = ref place in + let title = strip_abbrev_lower title in + let place = strip_abbrev_lower place in + let select x t = + if strip_abbrev_lower (sou base t.t_title) = title && + strip_abbrev_lower (sou base t.t_place) = place then + do clean_title.val := sou base t.t_title; + clean_place.val := sou base t.t_place; + return list.val := [(x, t) :: list.val] + else () + in + do for i = 0 to base.persons.len - 1 do + let x = base.persons.get i in List.iter (select x) x.titles; + done; + return (list.val, clean_title.val, clean_place.val) +; + +value select_title base title = + let list = ref [] in + let clean_name = ref title in + let title = strip_abbrev_lower title in + let add_place t = + let tn = sou base t.t_title in + if strip_abbrev_lower tn = title then + let pn = sou base t.t_place in + if not (List.mem pn list.val) then + do clean_name.val := tn; return + list.val := [pn :: list.val] + else () + else () + in + do for i = 0 to base.persons.len - 1 do + let x = base.persons.get i in List.iter add_place x.titles; + done; + return (list.val, clean_name.val) +; + +value select_place base place = + let list = ref [] in + let clean_name = ref place in + let place = strip_abbrev_lower place in + let add_title t = + let pn = sou base t.t_place in + if strip_abbrev_lower pn = place then + let tn = capitale (sou base t.t_title) in + if not (List.mem tn list.val) then + do clean_name.val := pn; return + list.val := [tn :: list.val] + else () + else () + in + do for i = 0 to base.persons.len - 1 do + let x = base.persons.get i in List.iter add_title x.titles; + done; + return (list.val, clean_name.val) +; + +value select_all_titles base = + let list = ref [] in + let add_title t = + let tn = capitale (sou base t.t_title) in + if not (List.mem tn list.val) then list.val := [tn :: list.val] else () + in + do for i = 0 to base.persons.len - 1 do + let x = base.persons.get i in List.iter add_title x.titles; + done; + return list.val +; + +value select_all_places base = + let list = ref [] in + let add_place t = + if not (List.mem (sou base t.t_place) list.val) then + list.val := [sou base t.t_place :: list.val] + else () + in + do for i = 0 to base.persons.len - 1 do + let x = base.persons.get i in List.iter add_place x.titles; + done; + return list.val +; + +value give_access_someone conf base (x, t) list = + let t_date_start = Adef.od_of_codate t.t_date_start in + let t_date_end = Adef.od_of_codate t.t_date_end in + let has_dates = + match (t_date_start, t_date_end) with + [ (Some _, _) | (_, Some _) -> True + | _ -> False ] + in + do if has_dates then Wserver.wprint "" else (); + match t_date_start with + [ Some d -> Wserver.wprint "%d" (annee d) + | None -> () ]; + match t_date_end with + [ Some d -> Wserver.wprint "-%d" (annee d) + | None -> () ]; + if has_dates then Wserver.wprint ": " else (); + if List.memq x list then Wserver.wprint "" + else Wserver.wprint "" (commd conf) (acces conf base x); + match (t.t_name, x.public_name, x.nick_names) with + [ (Tmain, pn, [nn :: _]) when sou base pn <> "" -> + Wserver.wprint "%s %s %s" (sou base pn) (sou base nn) + (sou base x.surname) + | (Tmain, pn, []) when sou base pn <> "" -> + Wserver.wprint "%s %s" (sou base pn) (sou base x.surname) + | (Tname n, _, [nn :: _]) -> + Wserver.wprint "%s %s %s" (sou base n) (sou base nn) + (sou base x.surname) + | (Tname n, _, []) -> + Wserver.wprint "%s %s" (sou base n) (sou base x.surname) + | _ -> Wserver.wprint "%s" (person_text conf base x) ]; + Wserver.wprint "\n"; + Date.afficher_dates_courtes conf base x; + if t.t_nth <> 0 then + Wserver.wprint " (%s)" (transl_nth conf "nth" t.t_nth) + else (); + if List.memq x list then Wserver.wprint "" else Wserver.wprint ""; + Wserver.wprint "\n"; + return () +; + +value give_access_place conf base t p = + do Wserver.wprint "" (commd conf) + (code_varenv t) (code_varenv p); + Wserver.wprint "... "; + Wserver.wprint "%s" p; + Wserver.wprint "\n"; + return () +; + +value give_access_title conf t p = + do Wserver.wprint "" (commd conf) + (code_varenv t) (code_varenv p); + Wserver.wprint "%s" (capitale t); + Wserver.wprint "\n"; + return () +; + +value give_access_all_titles conf t = + do Wserver.wprint "" (commd conf) + (code_varenv t); + Wserver.wprint "%s" (capitale t); + Wserver.wprint "\n"; + return () +; + +value give_access_all_places conf t = + do Wserver.wprint "" (commd conf) + (code_varenv t); + Wserver.wprint "... %s" t; + Wserver.wprint "\n"; + return () +; + +value print_title_place_list conf base t p list = + let title h = + if h then Wserver.wprint "%s %s\n" (capitale t) p + else + do Wserver.wprint "\n" (commd conf) + (code_varenv t); + Wserver.wprint "%s\n" (capitale t); + Wserver.wprint "\n" (commd conf) + (code_varenv p); + Wserver.wprint "%s\n" p; + return () + in + do header conf title; + Wserver.wprint "
        \n"; + let _ = List.fold_left + (fun list x -> + do Wserver.wprint "
      • "; + give_access_someone conf base x list; + return [fst x :: list]) + [] list + in (); + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value print_title_place conf base t p = + let (l, t, p) = select_title_place conf base t p in + let list = Sort.list (compare_title_dates conf base) l in + print_title_place_list conf base t p list +; + +value print_places_list conf base t list = + let title _ = Wserver.wprint "%s" (capitale t) in + do header conf title; + Wserver.wprint "
        \n"; + List.iter + (fun p -> + do Wserver.wprint "
      • "; give_access_place conf base t p; return + ()) + list; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value print_places conf base t = + let (l, t) = select_title base t in + let list = Sort.list compare_places l in + match list with + [ [p] -> print_title_place conf base t p + | _ -> print_places_list conf base t list ] +; + +value print_titles conf base p = + let (l, p) = select_place base p in + let list = Sort.list compare_titles l in + let title _ = Wserver.wprint "... %s" p in + do header conf title; + Wserver.wprint "
        \n"; + List.iter + (fun t -> + do Wserver.wprint "
      • "; give_access_title conf t p; return ()) + list; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value print_all_titles conf base = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "all the titles")) + in + let list = let l = select_all_titles base in Sort.list compare_titles l in + do header conf title; + Wserver.wprint "
        \n"; + List.iter + (fun t -> + do Wserver.wprint "
      • "; give_access_all_titles conf t; return ()) + list; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value print_all_places conf base = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "all the places")) + in + let list = let l = select_all_places base in Sort.list compare_places l in + do header conf title; + Wserver.wprint "
        \n"; + List.iter + (fun t -> + do Wserver.wprint "
      • "; give_access_all_places conf t; return ()) + list; + Wserver.wprint "
      \n"; + trailer conf; + return () +; + +value print conf base = + match + (p_getenv conf.env "sm", p_getenv conf.env "t", p_getenv conf.env "p") + with + [ (Some _, Some t, Some p) -> print_title_place conf base t p + | (Some _, Some t, None) -> print_places conf base t + | (Some _, None, Some p) -> print_titles conf base p + | (_, Some "" | None, Some "" | None) -> print_all_titles conf base + | (_, Some "" | None, Some "*") -> print_all_places conf base + | (_, Some "" | None, Some p) -> print_titles conf base p + | (_, Some t, Some "" | None) -> print_places conf base t + | (_, Some t, Some p) -> print_title_place conf base t p ] +; diff --git a/src/update.ml b/src/update.ml new file mode 100644 index 0000000000..8fb03942d2 --- /dev/null +++ b/src/update.ml @@ -0,0 +1,547 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: update.ml,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +exception ModErr; + +value rec find_free_occ base f s i = + match + try Some (person_ht_find_unique base f s i) with [ Not_found -> None ] + with + [ Some _ -> find_free_occ base f s (i + 1) + | None -> i ] +; + +value print_same_name conf base p = + let f = sou base p.first_name in + let s = sou base p.surname in + let ipl = Gutil.person_ht_find_all base (f ^ " " ^ s) in + let f = Name.strip_lower f in + let s = Name.strip_lower s in + let pl = + List.fold_left + (fun pl ip -> + let p = poi base ip in + if Name.strip_lower (sou base p.first_name) = f + && Name.strip_lower (sou base p.surname) = s then + [p :: pl] + else pl) + [] ipl + in + let pl = Sort.list (fun p1 p2 -> p1.occ < p2.occ) pl in + match pl with + [ [_] -> () + | _ -> + do Wserver.wprint "

      %s:\n" + (capitale (transl conf "persons having the same name")); + tag "ul" begin + List.iter + (fun p -> + do Wserver.wprint "

    • \n"; + stag "a" "href=\"%s%s\"" (commd conf) (acces conf base p) + begin + Wserver.wprint "%s.%d %s" (sou base p.first_name) p.occ + (sou base p.surname); + end; + return ()) + pl; + end; + return () ] +; + +value insert_string conf base s = + try base.index_of_string s with + [ Not_found -> + let i = Adef.istr_of_int base.strings.len in + do base.patch_string i s; return i ] +; + +value update_misc_names_of_family base p = + match p.sexe with + [ Masculin -> + List.iter + (fun ifam -> + let fam = foi base ifam in + let cpl = coi base ifam in + List.iter + (fun ip -> + List.iter + (fun name -> + if not (List.memq ip (person_ht_find_all base name)) then + person_ht_add base name ip + else ()) + (person_misc_names base (poi base ip))) + [cpl.mother :: Array.to_list fam.children]) + (Array.to_list p.family) + | _ -> () ] +; + +value print_someone base p = + Wserver.wprint "%s%s %s" (sou base p.first_name) + (if p.occ = 0 then "" else "." ^ string_of_int p.occ) + (sou base p.surname) +; + +value print_first_name base p = + Wserver.wprint "%s%s" (sou base p.first_name) + (if p.occ = 0 then "" else "." ^ string_of_int p.occ) +; + +value print_error conf base = + fun + [ AlreadyDefined p -> + Wserver.wprint + (fcapitale + (ftransl conf "name \"%s.%d %s\" already used by %tthis person%t")) + (sou base p.first_name) p.occ (sou base p.surname) + (fun _ -> + Wserver.wprint "" (commd conf) (acces conf base p)) + (fun _ -> Wserver.wprint ".") + | OwnAncestor p -> + do print_someone base p; + Wserver.wprint "\n%s" + (transl conf "would be his/her own ancestor"); + return () + | BadSexOfMarriedPerson p -> + Wserver.wprint "%s." + (capitale (transl conf "cannot change sex of a married person")) ] +; + +value print_someone_ref conf base p = + Wserver.wprint "\n%s%s %s" + (commd conf) (acces conf base p) + (sou base p.first_name) + (if p.occ = 0 then "" else "." ^ string_of_int p.occ) + (sou base p.surname) +; + +value print_first_name_ref conf base p = + Wserver.wprint "\n%s%s" + (commd conf) (acces conf base p) + (sou base p.first_name) + (if p.occ = 0 then "" else "." ^ string_of_int p.occ) +; + +value print_warning conf base = + fun + [ BirthAfterDeath p -> + Wserver.wprint (ftransl conf "%t died before his/her birth") + (fun _ -> + do print_someone base p; + Date.afficher_dates_courtes conf base p; + return ()) + | ChangedOrderOfChildren fam before -> + let cpl = coi base fam.fam_index in + let fath = poi base cpl.father in + let moth = poi base cpl.mother in + do Wserver.wprint "%s\n" + (capitale (transl conf "changed order of children")); + Wserver.wprint "%s\n" (transl_nth conf "of" 0); + print_someone_ref conf base fath; + Wserver.wprint "\n%s\n" (transl conf "and"); + print_someone_ref conf base moth; + Wserver.wprint "\n
        "; + Wserver.wprint "\n
      • %s:\n" (capitale (transl conf "before")); + Wserver.wprint "\n"; + tag "ul" begin + Array.iter + (fun ip -> + let p = poi base ip in + do Wserver.wprint "
      • \n"; + if p.surname = fath.surname then + print_first_name_ref conf base p + else print_someone_ref conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return ()) + before; + end; + Wserver.wprint "\n
      • %s:\n" (capitale (transl conf "after")); + Wserver.wprint "\n"; + tag "ul" begin + Array.iter + (fun ip -> + let p = poi base ip in + do Wserver.wprint "
      • \n"; + if p.surname = fath.surname then + print_first_name_ref conf base p + else print_someone_ref conf base p; + Date.afficher_dates_courtes conf base p; + Wserver.wprint "\n"; + return ()) + fam.children; + end; + Wserver.wprint "
      "; + return () + | ChildrenNotInOrder fam elder x -> + let cpl = coi base fam.fam_index in + do Wserver.wprint + (fcapitale + (ftransl conf + "the following children of %t and %t are not in order")) + (fun _ -> print_someone base (poi base cpl.father)) + (fun _ -> print_someone base (poi base cpl.mother)); + Wserver.wprint ":\n"; + Wserver.wprint "
        "; + Wserver.wprint "\n
      • \n"; + print_first_name base elder; + Date.afficher_dates_courtes conf base elder; + Wserver.wprint "\n
      • \n"; + print_first_name base x; + Date.afficher_dates_courtes conf base x; + Wserver.wprint "
      "; + return () + | DeadTooEarlyToBeFather father child -> + Wserver.wprint + (ftransl conf + "%t is born more than 2 years after the death of his/her father %t") + (fun _ -> + do print_someone base child; + Date.afficher_dates_courtes conf base child; + return ()) + (fun _ -> + do print_someone base father; + Date.afficher_dates_courtes conf base father; + return ()) + | MarriageDateAfterDeath p -> + Wserver.wprint + (fcapitale (ftransl conf "marriage of %t after his/her death")) + (fun _ -> + do print_someone base p; + Date.afficher_dates_courtes conf base p; + return ()) + | MarriageDateBeforeBirth p -> + Wserver.wprint + (fcapitale (ftransl conf "marriage of %t before his/her birth")) + (fun _ -> + do print_someone base p; + Date.afficher_dates_courtes conf base p; + return ()) + | MotherDeadAfterChildBirth mother child -> + Wserver.wprint + (ftransl conf "%t is born after the death of his/her mother %t") + (fun _ -> + do print_someone base child; + Date.afficher_dates_courtes conf base child; + return ()) + (fun _ -> + do print_someone base mother; + Date.afficher_dates_courtes conf base mother; + return ()) + | ParentBornAfterChild p c -> + do print_someone base p; + Wserver.wprint "\n%s\n" + (transl conf "is born after his/her child"); + print_someone base c; + return () + | ParentTooYoung p a -> + do print_someone base p; + Wserver.wprint "\n%s\n" (transl conf "is a very young parent"); + Wserver.wprint "("; + Date.print_age conf a; + Wserver.wprint ")"; + return () + | TitleDatesError p t -> + Wserver.wprint + (fcapitale (ftransl conf "%t has incorrect title dates: %t")) + (fun _ -> + do print_someone base p; + Date.afficher_dates_courtes conf base p; + return ()) + (fun _ -> + Wserver.wprint "%s %s %s-%s" + (sou base t.t_title) (sou base t.t_place) + (match Adef.od_of_codate t.t_date_start with + [ Some d -> string_of_int (annee d) + | _ -> "" ]) + (match Adef.od_of_codate t.t_date_end with + [ Some d -> string_of_int (annee d) + | _ -> "" ])) + | YoungForMarriage p a -> + do print_someone base p; + Wserver.wprint "\n"; + Wserver.wprint (ftransl conf "married at age %t") + (fun _ -> Date.print_age conf a); + return () ] +; + +value print_warnings conf base wl = + if wl = [] then () + else + do Wserver.wprint "

      %s\n" (capitale (transl conf "warnings")); + tag "ul" begin + List.iter + (fun w -> + do Wserver.wprint "

    • \n"; + print_warning conf base w; + Wserver.wprint "\n"; + return ()) + wl; + end; + return () +; + +value error conf base x = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + print_error conf base x; + Wserver.wprint "\n"; + trailer conf; + return raise ModErr +; + +value error_locked conf base = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint + (fcapitale + (ftransl conf + "the file is temporarily locked: please try again")); + Wserver.wprint ".\n"; + trailer conf; + return () +; + +value error_digest conf base = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint + (fcapitale + (ftransl conf + "\ +the base has changed; do \"back\", \"reload\", and refill the form")); + Wserver.wprint ".\n"; + trailer conf; + return raise ModErr +; + +value digest_person (p : base_person) = Iovalue.digest p; +value digest_family (fam : base_family) = Iovalue.digest fam; + +value get var key env = + match p_getenv env (var ^ "_" ^ key) with + [ Some v -> v + | None -> failwith (var ^ "_" ^ key ^ " unbound") ] +; + +value get_number var key env = p_getint env (var ^ "_" ^ key); + +value bad_date conf d = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Wserver.wprint "%s:\n" (capitale (transl conf "incorrect date")); + match d with + [ Djma j m a -> Wserver.wprint "%d/%d/%d" j m a + | Dma m a -> Wserver.wprint "%d/%d" m a + | Da _ a -> Wserver.wprint "%d" a ]; + trailer conf; + return raise ModErr +; + +value reconstitute_date 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 (Djma d m y) + else bad_date conf (Djma d m y) + | None -> + if m >= 1 && m <= 12 then Some (Dma m y) + else bad_date conf (Dma m y) ] + | None -> + let prec = + match get var "prec" conf.env with + [ "about" -> About + | "maybe" -> Maybe + | "before" -> Before + | "after" -> After + | "oryear" -> OrYear (int_of_string (get var "oryear" conf.env)) + | _ -> Sure ] + in + Some (Da prec y) ] + | None -> None ] +; + +value print_date conf base lab var d = + do tag "tr" begin + stag "td" begin Wserver.wprint "%s" lab; end; + tag "td" begin + Wserver.wprint "\n" var + (match d with + [ Some (Djma j _ _) -> " value=" ^ string_of_int j + | _ -> "" ]); + Wserver.wprint "\n" var + (match d with + [ Some (Djma _ m _) -> " value=" ^ string_of_int m + | Some (Dma m _) -> " value=" ^ string_of_int m + | _ -> "" ]); + Wserver.wprint "\n" var + (match d with + [ Some (Djma _ _ y) -> " value=" ^ string_of_int y + | Some (Dma _ y) -> " value=" ^ string_of_int y + | Some (Da _ y) -> " value=" ^ string_of_int y + | _ -> "" ]); + end; + tag "td" begin + Wserver.wprint "%s\n" (capitale (transl conf "year precision")); + tag "select" "name=%s_prec" var begin + Wserver.wprint "-\n" + (match d with + [ Some (Djma _ _ _) | Some (Dma _ _) | None -> " selected" + | _ -> "" ]); + Wserver.wprint "
    • \n"; + Wserver.wprint "" + (commd conf) (Adef.int_of_iper p.cle_index) + (Adef.int_of_ifam fi); + Wserver.wprint "%s\n" (capitale (transl conf "switch")); + if cpl1.father = cpl2.father && cpl1.mother = cpl2.mother + then + do Wserver.wprint "
    • \n"; + stag "a" "href=\"%sm=MRG_FAM;f1=%d;f2=%d\"" + (commd conf) (Adef.int_of_ifam prev_fi) + (Adef.int_of_ifam fi) + begin + Wserver.wprint "%s" (capitale (transl conf "merge")); + end; + Wserver.wprint "\n"; + return () + else (); + return () + | None -> () ]; + return + let c = conjoint p (coi base fi) in + do Wserver.wprint "\n
    • \n"; + Wserver.wprint "" (commd conf) + (Adef.int_of_ifam fi); + Wserver.wprint "%s / %s\n" + (capitale (transl conf "modify")) + (capitale (transl_nth conf "family/families" 0)); + Wserver.wprint "\n%s\n" (transl conf "with"); + print_someone base (poi base c); + Wserver.wprint "\n
    • \n"; + Wserver.wprint "" (commd conf) + (Adef.int_of_ifam fi); + Wserver.wprint "%s / %s\n" + (capitale (transl conf "delete")) + (capitale (transl_nth conf "family/families" 0)); + Wserver.wprint "\n%s\n" (transl conf "with"); + print_someone base (poi base c); + return Some fi) + None (Array.to_list p.family) + in (); + if (sou base p.first_name = "?" || sou base p.surname = "?") + && (Array.length p.family <> 0 || a.parents <> None) then () + else + do Wserver.wprint "\n
    • \n"; + Wserver.wprint "%s / %s\n" + (commd conf) (Adef.int_of_iper p.cle_index) + (capitale (transl conf "add")) + (capitale (transl_nth conf "family/families" 0)); + return (); + end +; + +value print conf base p = + let title h = + do Wserver.wprint "%s" (capitale (transl conf "update")); + if h then () + else + let fn = sou base p.first_name in + let sn = sou base p.surname in + let occ = + if fn = "?" || sn = "?" then Adef.int_of_iper p.cle_index + else p.occ + in + do Wserver.wprint ": "; + Wserver.wprint "%s.%d %s" fn occ sn; + return (); + return () + in + let a = aoi base p.cle_index in + do header conf title; + Wserver.wprint "
        "; + Wserver.wprint "\n
      • \n"; + Wserver.wprint "%s\n" (commd conf) + (Adef.int_of_iper p.cle_index) + (capitale (transl conf "modify")); + Wserver.wprint "\n
      • \n"; + Wserver.wprint "%s\n" + (commd conf) (Adef.int_of_iper p.cle_index) + (capitale (transl conf "delete")); + Wserver.wprint "
      \n"; + Wserver.wprint "\n"; + print_family_stuff conf base p a; + match a.parents with + [ Some _ -> () + | None -> + if sou base p.first_name = "?" || sou base p.surname = "?" then () + else + do Wserver.wprint "
        "; + Wserver.wprint "\n
      • \n"; + Wserver.wprint "%s / %s\n" + (commd conf) (Adef.int_of_iper p.cle_index) + (capitale (transl conf "add")) + (capitale (transl conf "parents")); + Wserver.wprint "
      \n"; + return () ]; + Wserver.wprint "\n"; + Wserver.wprint "

      \n"; + tag "ul" begin + Wserver.wprint "

    • \n"; + stag "a" "href=\"%sm=MRG;i=%d\"" (commd conf) + (Adef.int_of_iper p.cle_index) + begin + Wserver.wprint "%s" (capitale (transl conf "merge")); + end; + end; + trailer conf; + return () +; diff --git a/src/update.mli b/src/update.mli new file mode 100644 index 0000000000..e4858ac02d --- /dev/null +++ b/src/update.mli @@ -0,0 +1,30 @@ +(* $Id: update.mli,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Config; + +exception ModErr; + +value find_free_occ : base -> string -> string -> int -> int; +value print_same_name : config -> base -> base_person -> unit; + +value insert_string : config -> base -> string -> Adef.istr; +value update_misc_names_of_family : base -> base_person -> unit; + +value print_error : config -> base -> Gutil.base_error -> unit; +value print_warnings : config -> base -> list Gutil.base_warning -> unit; +value error : config -> base -> Gutil.base_error -> 'a; + +value error_locked : config -> base -> unit; +value error_digest : config -> base -> 'a; + +value digest_person : base_person -> Digest.t; +value digest_family : base_family -> Digest.t; + +value reconstitute_date : config -> string -> option date; +value print_date : + config -> base -> string -> string -> option date -> unit; + +value print_someone : base -> base_person -> unit; + +value print : config -> base -> base_person -> unit; diff --git a/src/updateFam.ml b/src/updateFam.ml new file mode 100644 index 0000000000..4dbde0eaff --- /dev/null +++ b/src/updateFam.ml @@ -0,0 +1,450 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: updateFam.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Gutil; +open Util; +open Config; + +value bogus_family_index = Adef.ifam_of_int (-1); + +type create = [ Create of sexe | Link ]; +type str_indi = (string * string * int * create); + +value person_key base ip = + let p = poi base ip in + let first_name = sou base p.first_name in + let surname = sou base p.surname in + let occ = + if first_name = "?" || surname = "?" then Adef.int_of_iper ip else p.occ + in + (first_name, surname, occ, Link) +; + +value string_family_of base fam cpl = + let sfam = Gutil.map_family_ps (person_key base) (sou base) fam in + let scpl = Gutil.map_couple_p (person_key base) cpl in + (sfam, scpl) +; + +type family_member = [ Father | Mother | Child ]; + +value print_person conf base var fmem (first_name, surname, occ, create) = + tag "table" "border=1" begin + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" + (capitale (transl_nth conf "first name/first names" 0)); + end; + tag "td" begin + Wserver.wprint "" first_name; + end; + tag "td" "align=right" begin + let s = capitale (transl conf "number") in + let s = if String.length s > 3 then String.sub s 0 3 else s in + Wserver.wprint "%s" s; + end; + tag "td" begin + Wserver.wprint "" var + (if occ == 0 then "" else " value=" ^ string_of_int occ); + end; + tag "td" begin + tag "select" "name=%s_p" var begin + Wserver.wprint "
    • \n"; return + tag "table" "border=1" begin + tag "tr" begin + let var = "add_child" ^ string_of_int cnt in + tag "td" begin + Wserver.wprint "%s / %s " + (capitale (transl conf "insert")) + (capitale (transl_nth conf "child/children" 0)) + var; + end; + end; + end +; + +value print_child conf base cnt n = + do Wserver.wprint "\n
    • \n"; + print_person conf base ("child" ^ string_of_int cnt) Child n; + print_add_child conf base cnt; + return () +; + +value print_children conf base fam cpl force_children_surnames = + let children = + match Array.to_list fam.children with + [ [] -> [("", "", 0, Create Neutre)] + | ipl -> + let (_, father_surname, _, _) = cpl.father in + List.map + (fun (first_name, surname, occ, create) -> + let surname = + if not force_children_surnames && surname = father_surname then + "" + else surname + in + (first_name, surname, occ, create)) + ipl ] + in + do stag "h4" begin + Wserver.wprint "%s" (capitale (transl_nth conf "child/children" 1)); + end; + Wserver.wprint "\n"; + tag "ul" begin + print_add_child conf base 0; + let _ = List.fold_left + (fun cnt n -> do print_child conf base cnt n; return cnt + 1) + 1 children + in (); + end; + return () +; + +value print_comment conf base fam = + do stag "h4" begin + Wserver.wprint "%s" (capitale (transl conf "comment")); + end; + Wserver.wprint "\n"; + tag "table" "border=1" begin + tag "tr" begin + tag "td" begin + Wserver.wprint "\n" + (match fam.comment with + [ s when s <> "" -> " value=\"" ^ s ^ "\"" + | _ -> "" ]); + end; + end; + end; + return () +; + +value print_sources conf base field = + do tag "h4" begin + Wserver.wprint "%s" (capitale (transl conf "sources")); + end; + Wserver.wprint "\n"; + tag "table" "border=1" begin + tag "tr" begin + tag "td" begin + Wserver.wprint "\n" + (match field with + [ s when s <> "" -> " value=\"" ^ quote_escaped s ^ "\"" + | _ -> "" ]); + end; + end; + end; + return () +; + +value print_family conf base fam cpl force_children_surnames = + do print_father conf base cpl; + Wserver.wprint "\n"; + print_mother conf base cpl; + Wserver.wprint "\n"; + print_marriage conf base fam; + Wserver.wprint "\n"; + print_divorce conf base fam; + Wserver.wprint "\n"; + print_comment conf base fam; + Wserver.wprint "\n"; + print_children conf base fam cpl force_children_surnames; + Wserver.wprint "\n"; + print_sources conf base fam.fsources; + return () +; + +value print_mod1 conf base fam cpl digest = + let title _ = + Wserver.wprint "%s / %s # %d" (capitale (transl conf "modify")) + (capitale (transl_nth conf "family/families" 0)) + (Adef.int_of_ifam fam.fam_index) + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (Adef.int_of_ifam fam.fam_index); + Wserver.wprint "\n" digest; + print_family conf base fam cpl False; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_del1 conf base fam = + let title _ = + Wserver.wprint "%s / %s" (capitale (transl conf "delete")) + (capitale (transl_nth conf "family/families" 0)) + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n\n" + (Adef.int_of_ifam fam.fam_index); + Wserver.wprint "\n"; + Wserver.wprint "\n"; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_swi1 conf base p fam1 fam2 = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "switch")) + in + let cpl1 = coi base fam1.fam_index in + let cpl2 = coi base fam2.fam_index in + do header conf title; + Wserver.wprint "%s:" + (capitale (transl conf "switch the order of the following families")); + tag "ul" begin + Wserver.wprint "

    • \n"; + Update.print_someone base (poi base cpl1.father); + Wserver.wprint " %s " (transl conf "and"); + Update.print_someone base (poi base cpl1.mother); + Wserver.wprint "
    • \n"; + Update.print_someone base (poi base cpl2.father); + Wserver.wprint " %s " (transl conf "and"); + Update.print_someone base (poi base cpl2.mother); + end; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n\n" + (Adef.int_of_iper p.cle_index); + Wserver.wprint "\n\n" + (Adef.int_of_ifam fam2.fam_index); + Wserver.wprint "\n"; + Wserver.wprint "\n"; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_add1 conf base fam cpl force_children_surnames = + let title _ = + Wserver.wprint "%s / %s" (capitale (transl conf "add")) + (capitale (transl_nth conf "family/families" 0)) + in + do header conf title; + Wserver.wprint "\n"; + tag "form" "method=POST action=\"%s\"" conf.command begin + Srcfile.hidden_env conf; + Wserver.wprint "\n"; + print_family conf base fam cpl force_children_surnames; + Wserver.wprint "\n

      \n"; + Wserver.wprint "\n"; + end; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_add conf base = + let (fath, moth) = + match p_getint conf.env "i" with + [ Some i -> + let p = base.persons.get i in + let fath = + match p.sexe with + [ Masculin | Neutre -> person_key base p.cle_index + | Feminin -> ("", "", 0, Create Neutre) ] + in + let moth = + match p.sexe with + [ Feminin -> person_key base p.cle_index + | Masculin | Neutre -> ("", "", 0, Create Neutre) ] + in + (fath, moth) + | None -> (("", "", 0, Create Neutre), ("", "", 0, Create Neutre)) ] + in + let fam = + {marriage = Adef.codate_None; marriage_place = ""; + divorce = NotDivorced; children = [| |]; + comment = ""; origin_file = ""; fsources = ""; + fam_index = bogus_family_index} + and cpl = + {father = fath; mother = moth} + in + print_add1 conf base fam cpl False +; + +value print_add_parents conf base = + match p_getint conf.env "i" with + [ Some i -> + let p = base.persons.get i in + let fam = + {marriage = Adef.codate_None; marriage_place = ""; + divorce = NotDivorced; + children = + [| (sou base p.first_name, sou base p.surname, p.occ, Link) |]; + comment = ""; origin_file = ""; fsources = ""; + fam_index = bogus_family_index} + and cpl = + {father = ("", sou base p.surname, 0, Create Neutre); + mother = ("", "", 0, Create Neutre)} + in + print_add1 conf base fam cpl True + | _ -> incorrect_request conf ] +; + +value print_mod conf base = + match p_getint conf.env "i" with + [ Some i -> + let fam = foi base (Adef.ifam_of_int i) in + let cpl = coi base (Adef.ifam_of_int i) in + let (sfam, scpl) = string_family_of base fam cpl in + print_mod1 conf base sfam scpl (Update.digest_family fam) + | _ -> incorrect_request conf ] +; + +value print_del conf base = + match p_getint conf.env "i" with + [ Some i -> + let fam = foi base (Adef.ifam_of_int i) in + print_del1 conf base fam + | _ -> incorrect_request conf ] +; + +value rec find_families ifam = + fun + [ [ifam1; ifam2 :: ifaml] -> + if ifam2 = ifam then Some (ifam1, ifam2) + else find_families ifam [ifam2 :: ifaml] + | _ -> None ] +; + +value print_swi conf base = + match (p_getint conf.env "i", p_getint conf.env "f") with + [ (Some ip, Some ifam) -> + let p = base.persons.get ip in + match find_families (Adef.ifam_of_int ifam) (Array.to_list p.family) with + [ Some (ifam1, ifam2) -> + print_swi1 conf base p (foi base ifam1) (foi base ifam2) + | _ -> incorrect_request conf ] + | _ -> incorrect_request conf ] +; diff --git a/src/updateFam.mli b/src/updateFam.mli new file mode 100644 index 0000000000..26e18793a4 --- /dev/null +++ b/src/updateFam.mli @@ -0,0 +1,22 @@ +(* $Id: updateFam.mli,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Def; +open Config; + +type create = [ Create of sexe | Link ]; +type str_indi = (string * string * int * create); + +value print_add1 : + config -> base -> family str_indi string -> couple str_indi -> bool -> unit; +value print_mod1 : + config -> base -> family str_indi string -> couple str_indi -> string -> + unit; +value person_key : base -> iper -> str_indi; +value print_family : + config -> base -> family str_indi string -> couple str_indi -> bool -> unit; + +value print_add : config -> base -> unit; +value print_mod : config -> base -> unit; +value print_del : config -> base -> unit; +value print_swi : config -> base -> unit; +value print_add_parents : config -> base -> unit; diff --git a/src/updateFamOk.ml b/src/updateFamOk.ml new file mode 100644 index 0000000000..bf97a8a891 --- /dev/null +++ b/src/updateFamOk.ml @@ -0,0 +1,640 @@ +(* camlp4r ./pa_lock.cmo *) +(* $Id: updateFamOk.ml,v 1.1 1998-09-01 14:32:07 ddr Exp $ *) + +open Config; +open Def; +open Gutil; +open Util; + +value get env key = + match p_getenv env key with + [ Some v -> v + | None -> failwith (key ^ " unbound") ] +; + +value getn var key env = + match p_getenv env (var ^ "_" ^ key) with + [ Some v -> v + | None -> failwith (var ^ "_" ^ key ^ " unbound") ] +; + +value reconstitute_person env var = + let first_name = getn var "first_name" env in + let surname = getn var "surname" env in + let occ = try int_of_string (getn var "occ" env) with [ Failure _ -> 0 ] in + let create = + match getn var "p" env with + [ "create" -> UpdateFam.Create Neutre + | "create_M" -> UpdateFam.Create Masculin + | "create_F" -> UpdateFam.Create Feminin + | _ -> UpdateFam.Link ] + in + (first_name, surname, occ, create) +; + +value reconstitute_child env var default_surname = + let first_name = getn var "first_name" env in + let surname = + let surname = getn var "surname" env in + if surname = "" then default_surname else surname + in + let occ = try int_of_string (getn var "occ" env) with [ Failure _ -> 0 ] in + let create = + match getn var "p" env with + [ "create" -> UpdateFam.Create Neutre + | "create_M" -> UpdateFam.Create Masculin + | "create_F" -> UpdateFam.Create Feminin + | _ -> UpdateFam.Link ] + in + (first_name, surname, occ, create) +; + +value reconstitute_family conf = + let ext = False in + let father = reconstitute_person conf.env "his" in + let mother = reconstitute_person conf.env "her" in + let marriage = Update.reconstitute_date conf "marriage" in + let marriage_place = + match p_getenv conf.env "marriage_place" with + [ Some s -> s + | None -> "" ] + in + let divorce = + match p_getenv conf.env "divorce" with + [ Some "not_divorced" -> NotDivorced + | _ -> + Divorced + (Adef.codate_of_od + (Update.reconstitute_date conf "divorce")) ] + in + let surname = getn "his" "surname" conf.env in + let (children, ext) = + loop 1 False where rec loop i ext = + match + try + Some + (reconstitute_child conf.env ("child" ^ string_of_int i) surname) + with + [ Failure _ -> None ] + with + [ Some c -> + let (children, ext) = loop (i + 1) ext in + match p_getenv conf.env ("add_child" ^ string_of_int i) with + [ Some "on" -> + ([c; ("", "", 0, UpdateFam.Create Neutre) :: children], True) + | _ -> ([c :: children ], ext) ] + | None -> ([], ext) ] + in + let (children, ext) = + match p_getenv conf.env "add_child0" with + [ Some "on" -> ([("", "", 0, UpdateFam.Create Neutre) :: children], True) + | _ -> (children, ext) ] + in + let comment = + match p_getenv conf.env "comment" with + [ Some s -> s + | None -> "" ] + in + let fsources = + match p_getenv conf.env "src" with + [ Some s -> s + | None -> "" ] + in + let fam_index = + match p_getint conf.env "i" with + [ Some i -> i + | None -> 0 ] + in + let fam = + {marriage = Adef.codate_of_od marriage; + marriage_place = marriage_place; + divorce = divorce; children = Array.of_list children; comment = comment; + origin_file = ""; fsources = fsources; + fam_index = Adef.ifam_of_int fam_index} + and cpl = + {father = father; mother = mother} + in + (fam, cpl, ext) +; + +value new_persons = ref []; + +value add_misc_names_for_new_persons base = + do List.iter + (fun p -> + List.iter (fun n -> person_ht_add base n p.cle_index) + (person_misc_names base p)) + new_persons.val; + new_persons.val := []; + return () +; + +value print_err_unknown conf base (f, s, o) = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "error")) + in + do header conf title; + Wserver.wprint "%s: %s.%d %s\n" + (capitale (transl conf "unknown person")) f o s; + trailer conf; + return () +; + +value print_create_conflict conf base p = + let title _ = Wserver.wprint "%s" (capitale (transl conf "error")) in + do header conf title; + Update.print_error conf base (AlreadyDefined p); + Wserver.wprint "

      \n"; + Wserver.wprint "

        \n"; + Wserver.wprint "
      • %s: %d\n" + (capitale (transl conf "first free number")) + (Update.find_free_occ base (sou base p.first_name) (sou base p.surname) + 0); + Wserver.wprint "
      • %s\n" + (capitale (transl conf "or use \"link\" instead of \"create\"")); + Wserver.wprint "
      \n"; + Update.print_same_name conf base p; + trailer conf; + return () +; + +value insert_person conf base (f, s, o, create) = + let f = if f = "" then "?" else f in + let s = if s = "" then "?" else s in + match create with + [ UpdateFam.Create sexe -> + try + if f = "?" || s = "?" then + if o <= 0 || o >= base.persons.len then raise Not_found + else + let ip = Adef.iper_of_int o in + let p = poi base ip in + if sou base p.first_name = f && sou base p.surname = s then ip + else raise Not_found + else + let ip = person_ht_find_unique base f s o in + do print_create_conflict conf base (poi base ip); return + raise Update.ModErr + with + [ Not_found -> + let o = if f = "?" || s = "?" then 0 else o in + let ip = Adef.iper_of_int (base.persons.len) in + let empty_string = Update.insert_string conf base "" in + let p = + {first_name = Update.insert_string conf base f; + surname = Update.insert_string conf base s; + occ = o; photo = empty_string; + first_names_aliases = []; surnames_aliases = []; + public_name = empty_string; + nick_names = []; aliases = []; titles = []; + occupation = empty_string; + sexe = sexe; access = IfTitles; + birth = Adef.codate_None; birth_place = empty_string; + baptism = Adef.codate_None; baptism_place = empty_string; + death = DontKnowIfDead; death_place = empty_string; + burial = UnknownBurial; burial_place = empty_string; + family = [| |]; + notes = empty_string; + psources = empty_string; + cle_index = ip} + and a = + {parents = None; + consang = Adef.fix (-1)} + in + do base.patch_person p.cle_index p; + base.patch_ascend p.cle_index a; + if f <> "?" && s <> "?" then + do person_ht_add base (f ^ " " ^ s) ip; + new_persons.val := [p :: new_persons.val]; + return () + else (); + return ip ] + | UpdateFam.Link -> + if f = "?" || s = "?" then + if o < 0 || o >= base.persons.len then + do print_err_unknown conf base (f, s, o); return + raise Update.ModErr + else + let ip = Adef.iper_of_int o in + let p = poi base ip in + if sou base p.first_name = f && sou base p.surname = s then ip + else + do print_err_unknown conf base (f, s, o); return + raise Update.ModErr + else + try person_ht_find_unique base f s o with + [ Not_found -> + do print_err_unknown conf base (f, s, o); return + raise Update.ModErr ] ] +; + +value strip_children pl = + let pl = + List.fold_right + (fun ((f, s, o, c) as p) pl -> if f = "" then pl else [p :: pl]) + (Array.to_list pl) [] + in + Array.of_list pl +; + +value strip_family fam = + do fam.children := strip_children fam.children; + if Array.length fam.children <> 0 then fam.comment := "" else (); + return () +; + +value print_err_parents conf base p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "error")) + in + do header conf title; + Wserver.wprint "\n"; + Wserver.wprint (fcapitale (ftransl conf "%t already has parents")) + (fun _ -> afficher_personne_referencee conf base p); + Wserver.wprint "\n

      \n"; + Wserver.wprint "

      • %s: %d
      \n" + (capitale (transl conf "first free number")) + (Update.find_free_occ base (sou base p.first_name) (sou base p.surname) + 0); + trailer conf; + return () +; + +value print_err_father_sex conf base p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "error")) + in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n%s\n" (transl conf "should be of sex masculine"); + trailer conf; + return () +; + +value print_err_mother_sex conf base p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "error")) + in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n%s\n" (transl conf "should be of sex feminine"); + trailer conf; + return () +; + +value family_exclude pfams efam = + let pfaml = + List.fold_right + (fun fam faml -> if fam == efam then faml else [fam :: faml]) + (Array.to_list pfams) [] + in + Array.of_list pfaml +; + +value array_memq x a = + loop 0 where rec loop i = + if i == Array.length a then False + else if x == a.(i) then True + else loop (i + 1) +; + +value effective_mod conf base sfam scpl = + let fi = sfam.fam_index in + let ofam = foi base fi in + let ocpl = coi base fi in + let nfam = + map_family_ps (insert_person conf base) (Update.insert_string conf base) + sfam + in + let ncpl = map_couple_p (insert_person conf base) scpl in + let ofath = poi base ocpl.father in + let omoth = poi base ocpl.mother in + let nfath = poi base ncpl.father in + let nmoth = poi base ncpl.mother in + do match nfath.sexe with + [ Feminin -> + do print_err_father_sex conf base nfath; return raise Update.ModErr + | _ -> nfath.sexe := Masculin ]; + match nmoth.sexe with + [ Masculin -> + do print_err_mother_sex conf base nmoth; return raise Update.ModErr + | _ -> nmoth.sexe := Feminin ]; + nfam.origin_file := ofam.origin_file; + nfam.fam_index := fi; + base.patch_family fi nfam; + base.patch_couple fi ncpl; + if nfath.cle_index != ofath.cle_index then + do ofath.family := family_exclude ofath.family ofam.fam_index; + nfath.family := Array.append nfath.family [| fi |]; + base.patch_person ofath.cle_index ofath; + base.patch_person nfath.cle_index nfath; + return () + else (); + if nmoth.cle_index != omoth.cle_index then + do omoth.family := family_exclude omoth.family ofam.fam_index; + nmoth.family := Array.append nmoth.family [| fi |]; + base.patch_person omoth.cle_index omoth; + base.patch_person nmoth.cle_index nmoth; + return () + else (); + return + let find_asc = + let cache = Hashtbl.create 101 in + fun ip -> + try Hashtbl.find cache ip with + [ Not_found -> + let a = aoi base ip in + do Hashtbl.add cache ip a; return a ] + in + do Array.iter + (fun ip -> + let a = find_asc ip in + do a.parents := None; return + if not (array_memq ip nfam.children) then base.patch_ascend ip a + else ()) + ofam.children; + Array.iter + (fun ip -> + let a = find_asc ip in + match a.parents with + [ Some _ -> + do print_err_parents conf base (poi base ip); return + raise Update.ModErr + | None -> + do a.parents := Some fi; return + if not (array_memq ip ofam.children) then + base.patch_ascend ip a + else () ]) + nfam.children; + add_misc_names_for_new_persons base; + Update.update_misc_names_of_family base nfath; + return (nfam, ncpl) +; + +value effective_add conf base sfam scpl = + let fi = Adef.ifam_of_int (base.families.len) in + let nfam = + map_family_ps (insert_person conf base) (Update.insert_string conf base) + sfam + in + let ncpl = map_couple_p (insert_person conf base) scpl in + let origin_file = + let afath = aoi base ncpl.father in + let amoth = aoi base ncpl.mother in + match (afath.parents, amoth.parents) with + [ (Some if1, _) when sou base (foi base if1).origin_file <> "" -> + (foi base if1).origin_file + | (_, Some if2) when sou base (foi base if2).origin_file <> "" -> + (foi base if2).origin_file + | _ -> + loop 0 where rec loop i = + if i == Array.length nfam.children then + Update.insert_string conf base "" + else + let cifams = (poi base nfam.children.(i)).family in + if Array.length cifams == 0 then loop (i + 1) + else if sou base (foi base cifams.(0)).origin_file <> "" then + (foi base cifams.(0)).origin_file + else loop (i + 1) ] + in + let nfath = poi base ncpl.father in + let nmoth = poi base ncpl.mother in + do match nfath.sexe with + [ Feminin -> + do print_err_father_sex conf base nfath; return raise Update.ModErr + | _ -> nfath.sexe := Masculin ]; + match nmoth.sexe with + [ Masculin -> + do print_err_mother_sex conf base nmoth; return raise Update.ModErr + | _ -> nmoth.sexe := Feminin ]; + nfam.fam_index := fi; + nfam.origin_file := origin_file; + base.patch_family fi nfam; + base.patch_couple fi ncpl; + nfath.family := Array.append nfath.family [| fi |]; + nmoth.family := Array.append nmoth.family [| fi |]; + base.patch_person nfath.cle_index nfath; + base.patch_person nmoth.cle_index nmoth; + Array.iter + (fun ip -> + let a = aoi base ip in + let p = poi base ip in + match a.parents with + [ Some _ -> + do print_err_parents conf base p; return raise Update.ModErr + | None -> + do base.patch_ascend p.cle_index a; + a.parents := Some fi; + return () ]) + nfam.children; + add_misc_names_for_new_persons base; + Update.update_misc_names_of_family base nfath; + return (nfam, ncpl) +; + +value effective_swi conf base p ifam = + let rec loop = + fun + [ [ifam1; ifam2 :: ifaml] -> + if ifam2 = ifam then [ifam2; ifam1 :: ifaml] + else [ifam1 :: loop [ifam2 :: ifaml]] + | _ -> do incorrect_request conf; return raise Update.ModErr ] + in + do p.family := Array.of_list (loop (Array.to_list p.family)); + base.patch_person p.cle_index p; + return () +; + +value kill_family base fam ip = + let p = poi base ip in + let l = + List.fold_right + (fun ifam ifaml -> + if ifam == fam.fam_index then ifaml else [ifam :: ifaml]) + (Array.to_list p.family) [] + in + do p.family := Array.of_list l; + base.patch_person ip p; + return () +; + +value kill_parents base ip = + let a = aoi base ip in + do a.parents := None; + base.patch_ascend ip a; + return () +; + +value effective_del conf base fam = + let ifam = fam.fam_index in + let cpl = coi base ifam in + do kill_family base fam cpl.father; + kill_family base fam cpl.mother; + Array.iter (kill_parents base) fam.children; + cpl.father := Adef.iper_of_int (-1); + cpl.mother := Adef.iper_of_int (-1); + fam.children := [| |]; + fam.comment := Update.insert_string conf base ""; + fam.fam_index := Adef.ifam_of_int (-1); + base.patch_family ifam fam; + base.patch_couple ifam cpl; + return () +; + +value all_checks_family conf base fam cpl = + let wl = ref [] in + let error = Update.error conf base in + let warning w = wl.val := [w :: wl.val] in + do Gutil.check_noloop_for_person_list base error + [poi base cpl.father; poi base cpl.mother]; + Gutil.check_family base error warning fam; + return List.rev wl.val +; + +value print_family conf base wl fam cpl = + do Wserver.wprint "
        "; + Wserver.wprint "\n
      • \n"; + afficher_personne_referencee conf base (poi base cpl.father); + Wserver.wprint "\n"; + Wserver.wprint "\n
      • \n"; + afficher_personne_referencee conf base (poi base cpl.mother); + Wserver.wprint "
      \n"; + if fam.children <> [||] then + do Wserver.wprint "

      \n

        \n"; + Array.iter + (fun ip -> + do Wserver.wprint "
      • \n"; + afficher_personne_referencee conf base (poi base ip); + Wserver.wprint "\n"; + return ()) + fam.children; + Wserver.wprint "
      \n"; + return () + else (); + Update.print_warnings conf base wl; + return () +; + +value print_mod_ok conf base wl fam cpl = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "family modified")) + in + do header conf title; + print_family conf base wl fam cpl; + trailer conf; + return () +; + +value print_add_ok conf base wl fam cpl = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "family added")) + in + do header conf title; + print_family conf base wl fam cpl; + trailer conf; + return () +; + +value print_del_ok conf base wl = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "family deleted")) + in + do header conf title; + Update.print_warnings conf base wl; + trailer conf; + return () +; + +value print_swi_ok conf base p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "switch done")) + in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n"; + trailer conf; + return () +; + +value print_add conf base = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + try + let (sfam, scpl, ext) = reconstitute_family conf in + if ext then UpdateFam.print_add1 conf base sfam scpl False + else + do strip_family sfam; return + let (fam, cpl) = effective_add conf base sfam scpl in + let wl = all_checks_family conf base fam cpl in + do base.commit_patches (); + print_add_ok conf base wl fam cpl; + return () + with + [ Update.ModErr -> () ] + | Refuse -> Update.error_locked conf base ] +; + +value print_del conf base = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + match p_getint conf.env "i" with + [ Some i -> + let fam = foi base (Adef.ifam_of_int i) in + do if fam.fam_index <> Adef.ifam_of_int (-1) then + do effective_del conf base fam; + base.commit_patches (); + return () + else (); + print_del_ok conf base []; + return () + | _ -> incorrect_request conf ] + | Refuse -> Update.error_locked conf base ] +; + +value print_mod_aux conf base callback = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + try + let (sfam, scpl, ext) = reconstitute_family conf in + let digest = Update.digest_family (foi base sfam.fam_index) in + if digest = get conf.env "digest" then + if ext then UpdateFam.print_mod1 conf base sfam scpl digest + else + do strip_family sfam; return + callback sfam scpl + else Update.error_digest conf base + with + [ Update.ModErr -> () ] + | Refuse -> Update.error_locked conf base ] +; + +value print_mod conf base = + let callback sfam scpl = + let (fam, cpl) = effective_mod conf base sfam scpl in + let wl = all_checks_family conf base fam cpl in + do base.commit_patches (); + print_mod_ok conf base wl fam cpl; + return () + in + print_mod_aux conf base callback +; + +value print_swi conf base = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + match (p_getint conf.env "i", p_getint conf.env "f") with + [ (Some ip, Some ifam) -> + let p = base.persons.get ip in + try + do effective_swi conf base p (Adef.ifam_of_int ifam); + base.commit_patches (); + print_swi_ok conf base p; + return () + with [ Update.ModErr -> () ] + | _ -> incorrect_request conf ] + | Refuse -> Update.error_locked conf base ] +; diff --git a/src/updateInd.ml b/src/updateInd.ml new file mode 100644 index 0000000000..25f2e3ca0c --- /dev/null +++ b/src/updateInd.ml @@ -0,0 +1,684 @@ +(* camlp4r ./pa_html.cmo *) +(* $Id: updateInd.ml,v 1.1 1998-09-01 14:32:09 ddr Exp $ *) + +open Config; +open Def; +open Util; +open Gutil; + +value bogus_person_index = Adef.iper_of_int (-1); + +value string_title_of base t = + {t_name = + match t.t_name with + [ Tmain -> Tmain + | Tname s -> Tname (sou base s) + | Tnone -> Tnone ]; + t_title = sou base t.t_title; t_place = sou base t.t_place; + t_date_start = t.t_date_start; t_date_end = t.t_date_end; + t_nth = t.t_nth} +; + +value string_person_of base p = + let first_name = sou base p.first_name in + let surname = sou base p.surname in + let occ = + if first_name = "?" || surname = "?" then Adef.int_of_iper p.cle_index + else p.occ + in + Gutil.map_person_strings (sou base) p +; + +value print_first_name conf base p = + let occ = + if p.first_name = "?" || p.surname = "?" then Adef.int_of_iper p.cle_index + else p.occ + in + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" + (capitale (transl_nth conf "first name/first names" 0)); + end; + tag "td" begin + Wserver.wprint + "" + p.first_name; + end; + tag "td" begin + let s = capitale (transl conf "number") in + let s = if String.length s > 3 then String.sub s 0 3 else s in + Wserver.wprint "%s" s; + end; + tag "td" begin + Wserver.wprint " 0 then Wserver.wprint " value=%d" occ else (); + Wserver.wprint ">"; + end; + end +; + +value print_surname conf base p = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" + (capitale (transl_nth conf "surname/surnames" 0)); + end; + tag "td" begin + Wserver.wprint "" + p.surname; + end; + tag "td" begin Wserver.wprint "%s" (capitale (transl conf "sex")); end; + tag "td" begin + Wserver.wprint "%s\n" + (if p.sexe = Masculin then " checked" else "") + (transl_nth conf "M/F" 0); + Wserver.wprint "%s\n" + (if p.sexe = Feminin then " checked" else "") + (transl_nth conf "M/F" 1); + Wserver.wprint "?\n" + (if p.sexe = Neutre then " checked" else ""); + end; + end +; + +value print_public_name conf base p = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" (capitale (transl conf "public name")); + end; + tag "td" "colspan=3" begin + Wserver.wprint " "" then Wserver.wprint " value=\"%s\"" p.public_name + else (); + Wserver.wprint ">"; + end; + end +; + +value print_photo conf base p = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" (capitale (transl conf "photo")); + end; + tag "td" "colspan=3" begin + Wserver.wprint " "" then Wserver.wprint " value=\"%s\"" p.photo + else (); + Wserver.wprint ">"; + end; + end +; + +type item = + { i_name : string; i_txt_name : string; i_txt_add : string } +; + +value gen_print_ext_item conf base item i_cnt i_val = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s" (capitale item.i_txt_name); + end; + tag "td" begin + Wserver.wprint " "" then Wserver.wprint " value=\"%s\"" i_val else (); + Wserver.wprint ">"; + end; + tag "td" begin Wserver.wprint "%s" (capitale item.i_txt_add); end; + tag "td" begin + Wserver.wprint "" + item.i_name i_cnt; + end; + end +; + +value gen_print_ext_items conf base item i_proj = + let il = + match i_proj with + [ [] -> [""] + | il -> il ] + in + let _ = List.fold_left + (fun i_cnt i_val -> + do gen_print_ext_item conf base item i_cnt i_val; return + i_cnt + 1) + 0 il + in () +; + +value cons_update verb name = capitale verb; + +value print_nick_names conf base p = + gen_print_ext_items conf base + {i_name = "nickname"; i_txt_name = transl conf "qualifier"; + i_txt_add = cons_update (transl conf "insert") (transl conf "qualifier")} + p.nick_names +; + +value print_aliases conf base p = + gen_print_ext_items conf base + {i_name = "alias"; i_txt_name = transl conf "alias"; + i_txt_add = cons_update (transl conf "insert") (transl conf "alias")} + p.aliases +; + +value print_first_names_aliases conf base p = + gen_print_ext_items conf base + {i_name = "first_name_alias"; i_txt_name = transl conf "first name alias"; + i_txt_add = + cons_update (transl conf "insert") (transl conf "first name alias")} + p.first_names_aliases +; + +value print_surnames_aliases conf base p = + gen_print_ext_items conf base + {i_name = "surname_alias"; i_txt_name = transl conf "surname alias"; + i_txt_add = + cons_update (transl conf "insert") (transl conf "surname alias")} + p.surnames_aliases +; + +value print_birth_place conf base p = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s...\n" (capitale (transl_nth conf "born" 2)); + end; + tag "td" begin + Wserver.wprint "%s\n" (capitale (transl conf "place")); + end; + tag "td" begin + Wserver.wprint "\n" + (if p.birth_place = "" then "" + else " value=\"" ^ p.birth_place ^ "\""); + end; + end +; + +value print_bapt_place conf base p = + tag "tr" begin + tag "td" begin + Wserver.wprint "%s...\n" (capitale (transl_nth conf "baptized" 2)); + end; + tag "td" begin + Wserver.wprint "%s\n" (capitale (transl conf "place")); + end; + tag "td" begin + Wserver.wprint "\n" + (if p.baptism_place = "" then "" + else " value=\"" ^ p.baptism_place ^ "\""); + end; + end +; + +value print_birth_date conf base p = + let d = Adef.od_of_codate p.birth in + Update.print_date conf base (capitale (transl conf "date")) "birth" d +; + +value print_bapt_date conf base p = + let d = Adef.od_of_codate p.baptism in + Update.print_date conf base (capitale (transl conf "date")) "bapt" d +; + +value print_death_type conf base p = + tag "select" "name=death" begin + Wserver.wprint "
    • \n"; + afficher_personne_referencee conf base p; + Wserver.wprint "\n"; + end; + trailer conf; + return () +; + +value check_conflict conf base sp ipl = + let name = Name.strip_lower (sp.first_name ^ " " ^ sp.surname) in + List.iter + (fun ip -> + let p1 = poi base ip in + if p1.cle_index <> sp.cle_index + && Name.strip_lower (sou base p1.first_name ^ " " ^ sou base p1.surname) + = name + && p1.occ = sp.occ then + do print_conflict conf base p1; return raise Update.ModErr + else ()) + ipl +; + +value check_sex_married conf base sp op = + if sp.sexe <> op.sexe then + if Array.length op.family != 0 then + do print_cannot_change_sex conf base op; return raise Update.ModErr + else () + else () +; + +value effective_mod conf base sp = + let pi = sp.cle_index in + let op = poi base pi in + let key = sp.first_name ^ " " ^ sp.surname in + do if Name.strip_lower (sou base op.first_name) = + Name.strip_lower sp.first_name + && Name.strip_lower (sou base op.surname) = + Name.strip_lower sp.surname + && op.occ == sp.occ then () + else + let ipl = person_ht_find_all base key in + do check_conflict conf base sp ipl; return + person_ht_add base key pi; + check_sex_married conf base sp op; + return + let np = map_person_strings (Update.insert_string conf base) sp in + do np.family := op.family; return + let op_misc_names = person_misc_names base op in + let np_misc_names = person_misc_names base np in + do List.iter + (fun key -> + if List.mem key op_misc_names then () + else person_ht_add base key pi) + np_misc_names; + return np +; + +value effective_add conf base sp = + let pi = Adef.iper_of_int (base.persons.len) in + let key = sp.first_name ^ " " ^ sp.surname in + let ipl = person_ht_find_all base key in + do check_conflict conf base sp ipl; + person_ht_add base key pi; + return + let np = map_person_strings (Update.insert_string conf base) sp in + let na = {parents = None; consang = Adef.fix (-1)} in + do np.cle_index := pi; + base.patch_person pi np; + base.patch_ascend pi na; + return + let np_misc_names = person_misc_names base np in + do List.iter (fun key -> person_ht_add base key pi) np_misc_names; return + (np, na) +; + +value array_except v a = + loop 0 where rec loop i = + if i == Array.length a then a + else if a.(i) = v then + Array.append (Array.sub a 0 i) + (Array.sub a (i + 1) (Array.length a - i - 1)) + else loop (i + 1) +; + +value effective_del conf base p = + let none = Update.insert_string conf base "?" in + let empty = Update.insert_string conf base "" in + let asc = aoi base p.cle_index in + do match asc.parents with + [ Some ifam -> + let fam = foi base ifam in + do fam.children := array_except p.cle_index fam.children; + asc.parents := None; + asc.consang := Adef.fix (-1); + base.patch_family ifam fam; + base.patch_ascend p.cle_index asc; + return () + | None -> () ]; + p.first_name := none; + p.surname := none; + p.occ := 0; + p.photo := empty; + p.public_name := empty; + p.nick_names := []; + p.aliases := []; + p.first_names_aliases := []; + p.surnames_aliases := []; + p.titles := []; + p.occupation := empty; + p.access := IfTitles; + p.birth := Adef.codate_None; + p.birth_place := empty; + p.baptism := Adef.codate_None; + p.baptism_place := empty; + p.death := DontKnowIfDead; + p.death_place := empty; + p.burial := UnknownBurial; + p.burial_place := empty; + p.notes := empty; + p.psources := empty; + base.patch_person p.cle_index p; + return () +; + +value print_mod_ok conf base wl p = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "person modified")) + in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n"; + Update.print_warnings conf base wl; + trailer conf; + return () +; + +value all_checks_person conf base p a = + let wl = ref [] in + let error = Update.error conf base in + let warning w = wl.val := [w :: wl.val] in + do Gutil.check_person base error warning p; + match a.parents with + [ Some ifam -> Gutil.check_family base error warning (foi base ifam) + | _ -> () ]; + Array.iter + (fun ifam -> Gutil.check_family base error warning (foi base ifam)) + p.family; + List.iter + (fun + [ ChangedOrderOfChildren fam _ -> base.patch_family fam.fam_index fam + | _ -> () ]) + wl.val; + return List.rev wl.val +; + +value print_add_ok conf base wl p = + let title _ = Wserver.wprint "%s" (capitale (transl conf "person added")) in + do header conf title; + afficher_personne_referencee conf base p; + Wserver.wprint "\n"; + Update.print_warnings conf base wl; + trailer conf; + return () +; + +value print_del_ok conf base wl = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "person deleted")) + in + do header conf title; + Update.print_warnings conf base wl; + trailer conf; + return () +; + +value print_add conf base = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + try + let (p, ext) = reconstitute_person conf in + if ext then UpdateInd.print_add1 conf base p + else + do strip_person p; return + match check_person conf base p with + [ Some err -> error_person conf base p err + | None -> + let (p, a) = effective_add conf base p in + let wl = all_checks_person conf base p a in + do base.commit_patches (); + print_add_ok conf base wl p; + return () ] + with + [ Update.ModErr -> () ] + | Refuse -> Update.error_locked conf base ] +; + +value print_del conf base = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + match p_getint conf.env "i" with + [ Some i -> + let p = base.persons.get i in + do effective_del conf base p; + base.commit_patches (); + print_del_ok conf base []; + return () + | _ -> incorrect_request conf ] + | Refuse -> Update.error_locked conf base ] +; + +value print_mod_aux conf base callback = + let bfile = Filename.concat Util.base_dir.val conf.bname in + lock (Iobase.lock_file bfile) with + [ Accept -> + try + let (p, ext) = reconstitute_person conf in + let digest = Update.digest_person (poi base p.cle_index) in + if digest = get conf.env "digest" then + if ext then UpdateInd.print_mod1 conf base p digest + else + do strip_person p; return + match check_person conf base p with + [ Some err -> error_person conf base p err + | None -> callback p ] + else Update.error_digest conf base + with + [ Update.ModErr -> () ] + | Refuse -> Update.error_locked conf base ] +; + +value print_mod conf base = + let callback p = + let p = effective_mod conf base p in + let wl = + all_checks_person conf base p (aoi base p.cle_index) + in + do base.patch_person p.cle_index p; + Update.update_misc_names_of_family base p; + base.commit_patches (); + print_mod_ok conf base wl p; + return () + in + print_mod_aux conf base callback +; diff --git a/src/updateIndOk.mli b/src/updateIndOk.mli new file mode 100644 index 0000000000..d566a3a45e --- /dev/null +++ b/src/updateIndOk.mli @@ -0,0 +1,15 @@ +(* $Id: updateIndOk.mli,v 1.1 1998-09-01 14:32:09 ddr Exp $ *) + +open Config; +open Def; + +value effective_del : config -> base -> base_person -> unit; +value effective_mod : config -> base -> person string -> base_person; +value all_checks_person : + config -> base -> base_person -> ascend -> list Gutil.base_warning; +value print_mod_aux : config -> base -> (person string -> unit) -> unit; + +value print_add : config -> base -> unit; +value print_del : config -> base -> unit; +value print_mod : config -> base -> unit; + diff --git a/src/util.ml b/src/util.ml new file mode 100644 index 0000000000..d551489e90 --- /dev/null +++ b/src/util.ml @@ -0,0 +1,704 @@ +(* $Id: util.ml,v 1.1 1998-09-01 14:32:05 ddr Exp $ *) + +open Def; +open Config; +open Gutil; + +value version = "1.05+1"; + +value lang_dir = ref "."; +value base_dir = ref "."; + +value nl () = Wserver.wprint "\r\n"; + +value html conf = + if conf.cgi then + do Wserver.wprint "Content-type: text/html; charset=iso-8859-1"; + nl (); nl (); + return () + else Wserver.html () +; + +value rindex s conf = + pos (String.length s - 1) where rec pos i = + if i < 0 then None else if s.[i] = conf then Some i else pos (i - 1) +; + +value commd conf = + let c = conf.command ^ "?" in + List.fold_left + (fun c (k, v) -> c ^ k ^ (if v = "" then "" else "=" ^ v) ^ ";") c + conf.henv +; + +value code_varenv = Wserver.encode; +value decode_varenv = Wserver.decode; + +value p_getenv env label = + try Some (decode_varenv (List.assoc (decode_varenv label) env)) with + [ Not_found -> None ] +; + +value p_getint env label = + match p_getenv env label with + [ Some s -> try Some (int_of_string (strip_spaces s)) with _ -> None + | None -> None ] +; + +value lendemain (j, m, a) = + let (jour, r) = + if j >= nb_jours_dans_mois m a then (1, 1) else (succ j, 0) + in + let (mois, r) = if m + r > 12 then (1, 1) else (m + r, 0) in + let annee = a + r in (jour, mois, annee) +; + +value parent_has_title base p = + let a = aoi base p.cle_index in + match a.parents with + [ Some ifam -> + let cpl = coi base ifam in + let fath = poi base cpl.father in + let moth = poi base cpl.mother in + fath.access <> Private && fath.titles <> [] || + moth.access <> Private && moth.titles <> [] + | _ -> False ] +; + +value age_autorise conf base p = + if p.access = Public || conf.friend || conf.wizard then True + else if p.access = IfTitles && (p.titles <> [] || parent_has_title base p) + then True + else + match (Adef.od_of_codate p.birth, p.death) with + [ (_, Death _ d) -> + let a = annee (temps_ecoule (Adef.date_of_cdate d) conf.today) in + a > 100 + | (Some d, _) -> + let a = annee (temps_ecoule d conf.today) in + a > 100 + | _ -> + loop 0 where rec loop i = + if i >= Array.length p.family then False + else + let fam = foi base p.family.(i) in + match Adef.od_of_codate fam.marriage with + [ Some d -> let a = annee (temps_ecoule d conf.today) in a > 100 + | _ -> loop (i + 1) ] ] +; + +value nobr_level = ref 0; +value enter_nobr () = + do if nobr_level.val == 0 then Wserver.wprint "" else (); + incr nobr_level; + return () +; +value exit_nobr () = + do decr nobr_level; + if nobr_level.val == 0 then Wserver.wprint "" else (); + return () +; + +value start_with_vowel s = + if String.length s > 0 then + match s.[0] with + [ 'a' | 'e' | 'i' | 'o' | 'u' | 'y' | 'h' | 'A' | 'E' | 'I' | 'O' | 'U' | + 'Y' | 'H' | 'Á' | 'È' | 'É' -> + True + | _ -> False ] + else False +; + +value connais base p = + sou base p.first_name <> "?" || sou base p.surname <> "?" +; + +value acces_pur conf base x = + let first_name = sou base x.first_name in + let surname = sou base x.surname in + if conf.wizard && conf.friend && not (first_name = "?" || surname = "?") then + "n=" ^ code_varenv surname ^ ";p=" ^ code_varenv first_name ^ + (if x.occ > 0 then ";oc=" ^ string_of_int x.occ else "") + else + "i=" ^ string_of_int (Adef.int_of_iper x.cle_index) +; + +value acces conf base x = + let r = acces_pur conf base x in + if conf.senv = "" then r else "e=" ^ conf.senv ^ ";" ^ r +; + +value calculer_age conf p = + match Adef.od_of_codate p.birth with + [ None -> None + | Some d -> Some (temps_ecoule d conf.today) ] +; + +value person_text conf base p = + let beg = + match (sou base p.public_name, p.nick_names) with + [ ("", [nn :: _]) -> + sou base p.first_name ^ " " ^ sou base nn ^ "" + | ("", []) -> sou base p.first_name + | (n, [nn :: _]) -> n ^ " " ^ sou base nn ^ "" + | (n, []) -> n ] + in + beg ^ " " ^ sou base p.surname +; + +value person_text_no_html conf base p = + let beg = + match (sou base p.public_name, p.nick_names) with + [ ("", [nn :: _]) -> sou base p.first_name ^ " " ^ sou base nn + | ("", []) -> sou base p.first_name + | (n, [nn :: _]) -> n ^ " " ^ sou base nn + | (n, []) -> n ] + in + beg ^ " " ^ sou base p.surname +; + +value person_text_without_surname conf base p = + match (sou base p.public_name, p.nick_names) with + [ (n, [nn :: _]) when n <> "" -> n ^ " " ^ sou base nn ^ "" + | (n, []) when n <> "" -> n + | (_, [nn :: _]) -> + sou base p.first_name ^ " " ^ sou base nn ^ "" + | (_, []) -> sou base p.first_name ] +; + +value afficher_personne conf base p = + Wserver.wprint "%s" (person_text conf base p) +; + +value afficher_personne_referencee conf base p = + Wserver.wprint "\n%s" (commd conf) (acces conf base p) + (person_text conf base p) +; + +value afficher_nom_titre_reference conf base p s = + match p.nick_names with + [ [] -> + Wserver.wprint "%s" (commd conf) + (acces conf base p) s + | [nn :: _] -> + Wserver.wprint "%s %s" (commd conf) + (acces conf base p) s (sou base nn) ] +; + +value afficher_nom_titre conf base p s = Wserver.wprint "%s" s; + +value afficher_prenom_de_personne_referencee conf base p = + Wserver.wprint "%s" (commd conf) (acces conf base p) + (person_text_without_surname conf base p) +; + +value afficher_prenom_de_personne conf base p = + Wserver.wprint "%s" (person_text_without_surname conf base p) +; + +value most_prestigious base = + let val = + fun + [ "empereur" | "impératrice" -> 6 + | "roi" | "reine" -> 5 + | "prince" | "princesse" -> 4 + | "duc" | "duchesse" -> 3 + | "comte" | "comtesse" -> 2 + | "vicomte" | "vicomtesse" -> 1 + | _ -> 0 ] + in + let rec loop r = + fun + [ [] -> r + | [x :: l] -> + if x.t_name == Tmain then Some x + else + match r with + [ Some t -> + if val (sou base x.t_title) > val (sou base t.t_title) then + loop (Some x) l + else loop r l + | None -> loop (Some x) l ] ] + in + loop None +; + +value afficher_personne_un_titre_referencee conf base p t = + do if Name.strip_lower (sou base t.t_place) = + Name.strip_lower (sou base p.surname) + then + match (t.t_name, p.nick_names) with + [ (Tname n, []) -> + Wserver.wprint "%s" (commd conf) + (acces conf base p) (sou base n) + | (Tname n, [nn :: _]) -> + Wserver.wprint "%s %s" (commd conf) + (acces conf base p) (sou base n) (sou base nn) + | _ -> afficher_prenom_de_personne_referencee conf base p ] + else + match t.t_name with + [ Tname s -> afficher_nom_titre_reference conf base p (sou base s) + | _ -> afficher_personne_referencee conf base p ]; + Wserver.wprint ", %s %s" (sou base t.t_title) + (sou base t.t_place); + return () +; + +value afficher_personne_titre_referencee conf base p = + if p.access <> Private || conf.friend || conf.wizard then + match most_prestigious base p.titles with + [ Some t -> afficher_personne_un_titre_referencee conf base p t + | None -> afficher_personne_referencee conf base p ] + else + afficher_personne_referencee conf base p +; + +value afficher_personne_un_titre conf base p t = + do if t.t_place == p.surname then + match t.t_name with + [ Tname n -> Wserver.wprint "%s" (sou base n) + | _ -> afficher_prenom_de_personne conf base p ] + else + match t.t_name with + [ Tname s -> afficher_nom_titre conf base p (sou base s) + | _ -> afficher_personne conf base p ]; + Wserver.wprint ", %s %s" (sou base t.t_title) + (sou base t.t_place); + return () +; + +value afficher_personne_titre conf base p = + if p.access <> Private || conf.friend || conf.wizard then + match most_prestigious base p.titles with + [ Some t -> afficher_personne_un_titre conf base p t + | None -> afficher_personne conf base p ] + else afficher_personne conf base p +; + +value afficher_personne_sans_titre conf base p = + match most_prestigious base p.titles with + [ Some t -> + do if t.t_place == p.surname then + afficher_prenom_de_personne conf base p + else + match (t.t_name, p.nick_names) with + [ (Tname s, [nn :: _]) -> + Wserver.wprint "%s %s" (sou base s) (sou base nn) + | (Tname s, _) -> Wserver.wprint "%s" (sou base s) + | _ -> afficher_personne conf base p ]; + return () + | None -> afficher_personne conf base p ] +; + +value afficher_un_titre conf base p t = + let place = sou base t.t_place in + do Wserver.wprint ", %s" (sou base t.t_title); + if place = "" then () else Wserver.wprint " %s" place; + Wserver.wprint ""; + return () +; + +value afficher_titre conf base p = + if p.access <> Private || conf.friend || conf.wizard then + match most_prestigious base p.titles with + [ Some t -> afficher_un_titre conf base p t + | None -> () ] + else () +; + +value surname_begin n = + let i = initiale n in + if i == 0 then "" + else + let i = + strip_spaces i where rec strip_spaces i = + if n.[i - 1] == ' ' then strip_spaces (pred i) else i + in + " (" ^ String.sub n 0 i ^ ")" +; + +value surname_end n = + let i = initiale n in + if i == 0 then n else String.sub n i (String.length n - i) +; + +value create_env s = + let rec get_assoc beg i = + if i == String.length s then + if i == beg then [] else [String.sub s beg (i - beg)] + else if s.[i] == ';' || s.[i] == '&' then + [String.sub s beg (i - beg) :: get_assoc (succ i) (succ i)] + else get_assoc beg (succ i) + in + let rec separate i s = + if i = String.length s then (s, "") + else if s.[i] == '=' then + (String.sub s 0 i, String.sub s (succ i) (String.length s - succ i)) + else separate (succ i) s + in + List.map (separate 0) (get_assoc 0 0) +; + +value match_begin s t = + loop 0 0 where rec loop i j = + if i >= String.length s || j >= String.length t then True + else if s.[i] = t.[j] then loop (i + 1) (j + 1) + else False +; + +value rec capitale s = + if String.length s == 0 then "" + else + match s.[0] with + [ 'a'..'z' | 'à'..'ö' | 'ø'..'ý' -> + String.make 1 + (Char.chr (Char.code s.[0] - Char.code 'a' + Char.code 'A')) ^ + String.sub s 1 (String.length s - 1) + | '&' -> + if String.length s == 1 then s + else if match_begin s "¡" then + "¡" ^ capitale (String.sub s 7 (String.length s - 7)) + else + match s.[1] with + [ 'a'..'z' -> + "&" ^ + String.make 1 + (Char.chr + (Char.code s.[1] - Char.code 'a' + Char.code 'A')) ^ + String.sub s 2 (String.length s - 2) + | _ -> s ] + | _ -> s ] +; + +value fcapitale a = Obj.magic capitale a; + +value nth_field w n = + let rec start i n = + if n == 0 then i + else if i < String.length w then + if w.[i] == '/' then start (i + 1) (n - 1) else start (i + 1) n + else i + in + let rec stop i = + if i < String.length w then if w.[i] == '/' then i else stop (i + 1) + else i + in + let i1 = start 0 n in + let i2 = stop i1 in + let (i1, i2) = if i2 == i1 then (0, stop 0) else (i1, i2) in + String.sub w i1 (i2 - i1) +; + +value transl conf w = + try Hashtbl.find conf.lexicon w with [ Not_found -> "[" ^ w ^ "]" ] +; + +value transl_nth conf w n = + try nth_field (Hashtbl.find conf.lexicon w) n with + [ Not_found -> "[" ^ nth_field w n ^ "]" ] +; + +value transl_concat conf w s = + let wt = transl conf w in + if wt.[String.length wt - 1] = ''' then + if String.length s > 0 && start_with_vowel s then nth_field wt 1 ^ s + else nth_field wt 0 ^ " " ^ s + else wt ^ " " ^ s +; + +value ftransl conf (s : format 'a 'b 'c) : format 'a 'b 'c = + Obj.magic transl conf s +; + +value ftransl_nth conf (s : format 'a 'b 'c) p : format 'a 'b 'c = + Obj.magic transl_nth conf s p +; + +value index_of_sex = + fun + [ Masculin -> 0 + | Feminin -> 1 + | Neutre -> 2 ] +; + +value header conf title = + do html conf; + Wserver.wprint "\ +\n"; + Wserver.wprint "\n"; + Wserver.wprint " \n"; + Wserver.wprint " "; + title True; + Wserver.wprint "\n"; + Wserver.wprint "\n"; + Wserver.wprint "\n" + (try " " ^ List.assoc "body_prop" conf.base_env with + [ Not_found -> "" ]); + Wserver.wprint "

      "; + title False; + Wserver.wprint "

      \n"; + return () +; + +value rec copy_from_channel ic = + try + while True do + match input_char ic with + [ '%' -> + let c = input_char ic in + match c with + [ '%' -> Wserver.wprint "%%" + | 'v' -> Wserver.wprint "%s" version + | c -> do Wserver.wprint "%%"; return Wserver.wprint "%c" c ] + | c -> Wserver.wprint "%c" c ]; + done + with + [ End_of_file -> close_in ic ] +; + +value copy_from_file fname = + let fname = + List.fold_right Filename.concat [lang_dir.val; "lang"] + (Filename.basename fname ^ ".txt") + in + let ic = open_in fname in + copy_from_channel ic +; + +value trailer conf = + do try copy_from_file "copyr" with _ -> + Wserver.wprint " +

      © Copyright INRIA 1998 - +GeneWeb %s
      \n" version; + let trl_fname = + List.fold_right Filename.concat [base_dir.val; "lang"; conf.lang] + (conf.bname ^ ".trl") + in + match try Some (open_in trl_fname) with _ -> None with + [ Some ic -> copy_from_channel ic + | None -> + let trl_fname = + List.fold_right Filename.concat [base_dir.val; "lang"] + (conf.bname ^ ".trl") + in + try copy_from_channel (open_in trl_fname) with _ -> () ]; + Wserver.wprint "\n"; + return () +; + +value menu_threshold = 20; + +value is_number t = + match t.[0] with + [ '1'..'9' -> True + | _ -> False ] +; + +value print_alphab_list crit print_elem liste = + let len = List.length liste in + do if len > menu_threshold then + let _ = + List.fold_left + (fun last e -> + let t = crit e in + let same_than_last = + match last with + [ Some t1 -> t = t1 + | _ -> False ] + in + do if not same_than_last then + Wserver.wprint "%s\n" t t + else (); + return Some t) + None liste + in + () + else (); + Wserver.wprint "
        \n"; + let _ = + List.fold_left + (fun last e -> + let t = crit e in + let same_than_last = + match last with + [ Some t1 -> t = t1 + | _ -> False ] + in + do if len > menu_threshold || is_number t then + do match last with + [ Some _ -> + if not same_than_last then Wserver.wprint "
      \n" + else () + | _ -> () ]; + if not same_than_last then + do Wserver.wprint "
    • %s\n" t t; + Wserver.wprint "
        \n"; + return () + else (); + return () + else (); + Wserver.wprint "
      • "; + print_elem e; + return Some t) + None liste + in + (); + if len > menu_threshold then Wserver.wprint "
      \n" else (); + Wserver.wprint "
    \n"; + return () +; + +value print_parent conf base p a = + let is = index_of_sex p.sexe in + match p.public_name with + [ n when sou base n <> "" -> + let n = sou base n in + do Wserver.wprint "%s %s" (transl_nth conf "son/daughter/child" is) + (transl_concat conf "of" n); + afficher_titre conf base a; + return () + | _ -> + Wserver.wprint "%s %s%s" (transl_nth conf "son/daughter/child" is) + (transl_concat conf "of" (sou base a.first_name)) + (if p.surname <> a.surname then " " ^ sou base a.surname else "") ] +; + +value conjoint p fam = + if p.cle_index == fam.father then fam.mother + else if p.cle_index == fam.mother then fam.father + else invalid_arg "conjoint" +; + +value preciser_homonyme conf base p = + let is = index_of_sex p.sexe in + match (p.public_name, p.nick_names) with + [ (n, [nn :: _]) when sou base n <> ""-> + Wserver.wprint "%s %s" (sou base n) (sou base nn) + | (_, [nn :: _]) -> + Wserver.wprint "%s %s" (sou base p.first_name) (sou base nn) + | (n, []) when sou base n <> "" -> Wserver.wprint "%s" (sou base n) + | (_, []) -> + let a = aoi base p.cle_index in + match a.parents with + [ Some fam + when sou base (poi base (coi base fam).father).first_name <> "?" -> + print_parent conf base p (poi base (coi base fam).father) + | Some fam + when sou base (poi base (coi base fam).mother).first_name <> "?" -> + print_parent conf base p (poi base (coi base fam).mother) + | _ -> + let rec loop i = + if i < Array.length p.family then + let fam = foi base p.family.(i) in + let conjoint = conjoint p (coi base p.family.(i)) in + let ct = fam.children in + if Array.length ct > 0 then + let enfant = poi base ct.(0) in + Wserver.wprint "%s %s%s" (transl_nth conf "father/mother" is) + (transl_concat conf "of" (sou base enfant.first_name)) + (if p.surname <> enfant.surname then + " " ^ sou base enfant.surname + else "") + else + let conjoint = poi base conjoint in + if sou base conjoint.first_name <> "?" || + sou base conjoint.surname <> "?" then + Wserver.wprint "%s %s %s" + (transl_nth conf "husband/wife" is) + (transl_concat conf "of" (sou base conjoint.first_name)) + (sou base conjoint.surname) + else loop (i + 1) + else Wserver.wprint "..." + in + loop 0 ] ] +; + +value incorrect_request conf = + let title _ = + Wserver.wprint "%s" (capitale (transl conf "incorrect request")) + in + do header conf title; trailer conf; return () +; + +value print_decimal_num conf f = + let s = string_of_float f in + loop 0 where rec loop i = + if i == String.length s then () + else + do match s.[i] with + [ '.' -> Wserver.wprint "%s" (transl conf "(decimal separator)") + | x -> Wserver.wprint "%c" x ]; + return loop (i + 1) +; + +value list_find f = + loop where rec loop = + fun + [ [] -> None + | [x :: l] -> if f x then Some x else loop l ] +; + +value find_person_in_env conf base suff = + match p_getint conf.env ("i" ^ suff) with + [ Some i -> Some (base.persons.get i) + | None -> + match + (p_getenv conf.env ("p" ^ suff), p_getenv conf.env ("n" ^ suff)) + with + [ (Some p, Some n) -> + let occ = + match p_getint conf.env ("oc" ^ suff) with + [ Some oc -> oc + | None -> 0 ] + in + let k = p ^ " " ^ n in + let xl = List.map (poi base) (person_ht_find_all base k) in + let k = Name.strip_lower k in + list_find + (fun x -> + Name.strip_lower + (sou base x.first_name ^ " " ^ sou base x.surname) + = k && + x.occ == occ) + xl + | _ -> None ] ] +; + +value quote_escaped s = + let rec need_code i = + if i < String.length s then + match s.[i] with + [ '"' | '&' | '<' | '>' -> True + | x -> need_code (succ i) ] + else False + in + let rec compute_len i i1 = + if i < String.length s then + let i1 = + match s.[i] with + [ '"' -> i1 + 6 + | '&' -> i1 + 5 + | '<' | '>' -> i1 + 4 + | _ -> succ i1 ] + in + compute_len (succ i) i1 + else i1 + in + let rec copy_code_in s1 i i1 = + if i < String.length s then + let i1 = + match s.[i] with + [ '"' -> do String.blit """ 0 s1 i1 6; return i1 + 6 + | '&' -> do String.blit "&" 0 s1 i1 5; return i1 + 5 + | '<' -> do String.blit "<" 0 s1 i1 4; return i1 + 4 + | '>' -> do String.blit ">" 0 s1 i1 4; return i1 + 4 + | c -> do s1.[i1] := c; return succ i1 ] + in + copy_code_in s1 (succ i) i1 + else s1 + in + if need_code 0 then + let len = compute_len 0 0 in copy_code_in (String.create len) 0 0 + else s +; diff --git a/src/util.mli b/src/util.mli new file mode 100644 index 0000000000..b2b90f4589 --- /dev/null +++ b/src/util.mli @@ -0,0 +1,79 @@ +(* $Id: util.mli,v 1.1 1998-09-01 14:32:06 ddr Exp $ *) + +open Def; +open Config; + +value version : string; + +value lang_dir : ref string; +value base_dir : ref string; + +value html : config -> unit; + +value commd : config -> string; +value code_varenv : string -> string; +value decode_varenv : string -> string; + +value lendemain : (int * int * int) -> (int * int * int); +value age_autorise : config -> base -> base_person -> bool; + +value enter_nobr : unit -> unit; +value exit_nobr : unit -> unit; + +value connais : base -> base_person -> bool; +value acces : config -> base -> base_person -> string; +value calculer_age : config -> base_person -> option date; +value person_text : config -> base -> base_person -> string; +value person_text_no_html : config -> base -> base_person -> string; +value person_text_without_surname : config -> base -> base_person -> string; +(**) +value afficher_personne : config -> base -> base_person -> unit; +value afficher_prenom_de_personne_referencee : + config -> base -> base_person -> unit; +value afficher_personne_referencee : config -> base -> base_person -> unit; +(**) +value afficher_prenom_de_personne : config -> base -> base_person -> unit; +value afficher_personne_titre : config -> base -> base_person -> unit; +value afficher_personne_titre_referencee : config -> base -> base_person -> unit; +value afficher_personne_un_titre_referencee : + config -> base -> base_person -> title istr -> unit; +value afficher_personne_sans_titre : config -> base -> base_person -> unit; +value afficher_titre : config -> base -> base_person -> unit; +value afficher_un_titre : + config -> base -> base_person -> title istr -> unit; +value p_getenv : list (string * string) -> string -> option string; +value p_getint : list (string * string) -> string -> option int; +value create_env : string -> list (string * string); +value capitale : string -> string; + +value header : config -> (bool -> unit) -> unit; +value trailer : config -> unit; + +value print_alphab_list : ('a -> string) -> ('a -> unit) -> list 'a -> unit; + +value surname_begin : string -> string; +value surname_end : string -> string; + +value enter_nobr : unit -> unit; +value exit_nobr : unit -> unit; + +value preciser_homonyme : config -> base -> base_person -> unit; + +value transl : config -> string -> string; +value transl_nth : config -> string -> int -> string; +value transl_concat : config -> string -> string -> string; +value ftransl : config -> format 'a 'b 'c -> format 'a 'b 'c; +value ftransl_nth : config -> format 'a 'b 'c -> int -> format 'a 'b 'c; +value fcapitale : format 'a 'b 'c -> format 'a 'b 'c; + +value index_of_sex : sexe -> int; +value conjoint : base_person -> base_couple -> iper; + +value incorrect_request : config -> unit; + +value print_decimal_num : config -> float -> unit; + +value find_person_in_env : config -> base -> string -> option base_person; + +value quote_escaped : string -> string; +value rindex : string -> char -> option int; diff --git a/tools/Makefile.inc b/tools/Makefile.inc new file mode 100644 index 0000000000..b43b97202f --- /dev/null +++ b/tools/Makefile.inc @@ -0,0 +1,37 @@ +# $Id: Makefile.inc,v 1.1 1998-09-01 14:32:18 ddr Exp $ + +CAMLP4_COMM=../tools/camlp4_comm.sh pa_ifdef.cmo pa_ru.cmo +CAMLP4F=-DUNIX +CAMLP4D=`camlp4 -where` +LIBUNIX=-cclib -lunix +OCAMLC=ocamlc.opt +OCAMLOPT=ocamlopt.opt +OCAMLI= +RM=/bin/rm -f +EXE= + +all:: +opt:: + +clean:: + $(RM) *.out *.opt *.cm[oixa] *.cmxa *.pp[oi] *.o *.obj *.lck *.bak *~ .#* + +.SUFFIXES: .ml .cmo .mli .cmi .cmx + +.mli.cmi: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppi + $(OCAMLC) $(OCAMLI) -I $(CAMLP4D) -c -intf $*.ppi + $(RM) $*.ppi + +.ml.cmo: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppo + $(OCAMLC) $(OCAMLI) -I $(CAMLP4D) -c -impl $*.ppo + $(RM) $*.ppo + +.ml.cmx: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppo + $(OCAMLOPT) $(OCAMLI) -I $(CAMLP4D) -c -impl $*.ppo + $(RM) $*.ppo diff --git a/tools/Makefile.inc.win b/tools/Makefile.inc.win new file mode 100644 index 0000000000..e1756a65df --- /dev/null +++ b/tools/Makefile.inc.win @@ -0,0 +1,43 @@ +# $Id: Makefile.inc.win,v 1.1 1998-09-01 14:32:19 ddr Exp $ + +CAMLP4_COMM=../tools/camlp4_comm.sh pa_ifdef.cmo pa_ru.cmo +CAMLP4F=-DWIN95 +CAMLP4D=c:/camlp4/lib +LIBUNIX=c:/ocaml/lib/libunix.lib wsock32.lib +OCAMLC=ocamlc +OCAMLOPT=ocamlopt +OCAMLI= +RM=rm -f +EXE=.exe + +all:: +opt:: + +clean:: + $(RM) *.out *.opt *.cm[oixa] *.cmxa *.pp[oi] *.o *.obj *.lck *.bak *~ .#* + +depend: + ocamldep $(OCAMLI) *.ml* > .depend + + +.SUFFIXES: .ml .cmo .mli .cmi .cmx + +.mli.cmi: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppi + $(OCAMLC) $(OCAMLI) -I $(CAMLP4D) -c -intf $*.ppi + $(RM) $*.ppi + +.ml.cmo: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppo + $(OCAMLC) $(OCAMLI) -I $(CAMLP4D) -c -impl $*.ppo + $(RM) $*.ppo + +.ml.cmx: + @if test `basename $<` != $<; then echo "Bad directory for $<"; exit 1; fi + @$(CAMLP4_COMM) $(CAMLP4F) $< -o $*.ppo + $(OCAMLOPT) $(OCAMLI) -I $(CAMLP4D) -c -impl $*.ppo + $(RM) $*.ppo + +include .depend diff --git a/tools/camlp4_comm.sh b/tools/camlp4_comm.sh new file mode 100644 index 0000000000..3d81174c21 --- /dev/null +++ b/tools/camlp4_comm.sh @@ -0,0 +1,27 @@ +#!/bin/sh +# $Id: camlp4_comm.sh,v 1.1 1998-09-01 14:32:19 ddr Exp $ + +ARGS1= +FILE= +while test "" != "$1"; do + case $1 in + *.ml*) FILE=$1;; + *) ARGS1="$ARGS1 $1";; + esac + shift +done + +head -1 $FILE >/dev/null || exit 1 + +set - `head -1 $FILE` +if test "$2" = "camlp4r" -o "$2" = "camlp4o" -o "$2" = "camlp4"; then + COMM="$2" + shift; shift + ARGS2=`echo $* | sed -e "s/[()*]//g"` +else + COMM=camlp4r + ARGS2= +fi + +echo $COMM $ARGS2 $ARGS1 $FILE +$COMM $ARGS2 $ARGS1 $FILE diff --git a/wserver/Makefile b/wserver/Makefile new file mode 100644 index 0000000000..51ececea02 --- /dev/null +++ b/wserver/Makefile @@ -0,0 +1,13 @@ +# $Id: Makefile,v 1.1 1998-09-01 14:32:14 ddr Exp $ + +include ../tools/Makefile.inc + +OBJS=wserver.cmo + +all:: $(OBJS) +opt:: $(OBJS:.cmo=.cmx) + +depend: + ocamldep $(OCAMLI) *.ml* > .depend + +include .depend diff --git a/wserver/wserver.ml b/wserver/wserver.ml new file mode 100644 index 0000000000..1a7e0f5626 --- /dev/null +++ b/wserver/wserver.ml @@ -0,0 +1,526 @@ +(* $Id: wserver.ml,v 1.1 1998-09-01 14:32:14 ddr Exp $ *) + +open Unix; + +value wserver_oc = ref Pervasives.stdout; +value wprint fmt = Printf.fprintf wserver_oc.val fmt; +value wflush () = flush wserver_oc.val; + +value hexa_digit x = + if x >= 10 then Char.chr (Char.code 'A' + x - 10) + else Char.chr (Char.code '0' + x) +; + +value hexa_val conf = + match conf with + [ '0'..'9' -> Char.code conf - Char.code '0' + | 'a'..'f' -> Char.code conf - Char.code 'a' + 10 + | 'A'..'F' -> Char.code conf - Char.code 'A' + 10 + | _ -> 0 ] +; + +value decode s = + let rec need_decode i = + if i < String.length s then + match s.[i] with + [ '%' | '+' -> True + | _ -> need_decode (succ i) ] + else False + in + let rec compute_len i i1 = + if i < String.length s then + let i = + match s.[i] with + [ '%' when i + 2 < String.length s -> i + 3 + | _ -> succ i ] + in + compute_len i (succ i1) + else i1 + in + let rec copy_decode_in s1 i i1 = + if i < String.length s then + let i = + match s.[i] with + [ '%' when i + 2 < String.length s -> + let v = hexa_val s.[i + 1] * 16 + hexa_val s.[i + 2] in + do s1.[i1] := Char.chr v; return i + 3 + | '+' -> do s1.[i1] := ' '; return succ i + | x -> do s1.[i1] := x; return succ i ] + in + copy_decode_in s1 i (succ i1) + else s1 + in + let rec strip_heading_and_trailing_spaces s = + if String.length s > 0 then + if s.[0] == ' ' then + strip_heading_and_trailing_spaces + (String.sub s 1 (String.length s - 1)) + else if s.[String.length s - 1] == ' ' then + strip_heading_and_trailing_spaces + (String.sub s 0 (String.length s - 1)) + else s + else s + in + if need_decode 0 then + let len = compute_len 0 0 in + let s1 = String.create len in + strip_heading_and_trailing_spaces (copy_decode_in s1 0 0) + else s +; + +value special x = List.mem x ['='; '&'; ';'; '"'; '<'; '>']; + +value encode s = + let rec need_code i = + if i < String.length s then + match s.[i] with + [ ' ' -> True + | x -> if special x then True else need_code (succ i) ] + else False + in + let rec compute_len i i1 = + if i < String.length s then + let i1 = if special s.[i] then i1 + 3 else succ i1 in + compute_len (succ i) i1 + else i1 + in + let rec copy_code_in s1 i i1 = + if i < String.length s then + let i1 = + match s.[i] with + [ ' ' -> do s1.[i1] := '+'; return succ i1 + | c -> + if special c then + do s1.[i1] := '%'; + s1.[i1 + 1] := hexa_digit (Char.code c / 16); + s1.[i1 + 2] := hexa_digit (Char.code c mod 16); + return i1 + 3 + else do s1.[i1] := c; return succ i1 ] + in + copy_code_in s1 (succ i) i1 + else s1 + in + if need_code 0 then + let len = compute_len 0 0 in copy_code_in (String.create len) 0 0 + else s +; + +value nl () = + do wflush (); + let _ = write (Unix.descr_of_out_channel wserver_oc.val) "\r\n" 0 2 in (); + return () +; + +value html () = + do wprint "HTTP/1.0 200 OK"; nl (); + wprint "Content-type: text/html; charset=iso-8859-1"; nl (); nl (); + return () +; + +value print_exc exc = + match exc with + [ Unix_error err fun_name arg -> + do prerr_string "\""; + prerr_string fun_name; + prerr_string "\" failed"; + if String.length arg > 0 then + do prerr_string " on \""; prerr_string arg; prerr_string "\""; + return () + else (); + prerr_string ": "; + prerr_endline (error_message err); + return () + | Out_of_memory -> prerr_string "Out of memory\n" + | Match_failure (file, first_char, last_char) -> + do prerr_string "Pattern matching failed, file "; + prerr_string file; + prerr_string ", chars "; + prerr_int first_char; + prerr_char '-'; + prerr_int last_char; + return prerr_char '\n' + | Assert_failure (file, first_char, last_char) -> + do prerr_string "Assertion failed, file "; + prerr_string file; + prerr_string ", chars "; + prerr_int first_char; + prerr_char '-'; + prerr_int last_char; + return prerr_char '\n' + | x -> + do prerr_string "Uncaught exception: "; + prerr_string (Obj.magic (Obj.field (Obj.field (Obj.repr x) 0) 0)); + if Obj.size (Obj.repr x) > 1 then + do prerr_char '('; + for i = 1 to Obj.size (Obj.repr x) - 1 do + if i > 1 then prerr_string ", " else (); + let arg = Obj.field (Obj.repr x) i in + if not (Obj.is_block arg) then + prerr_int (Obj.magic arg : int) + else if Obj.tag arg = 252 then + do prerr_char '"'; prerr_string (Obj.magic arg : string); + return prerr_char '"' + else prerr_char '_'; + done; + return prerr_char ')' + else (); + return prerr_char '\n' ] +; + +value print_err_exc exc = + do print_exc exc; + Printf.eprintf "Please report.\n"; + flush Pervasives.stderr; + return () +; + +value case_unsensitive_eq s1 s2 = + String.lowercase s1 = String.lowercase s2 +; + +value rec extract_param name stop_char = + fun + [ [x :: l] -> + if String.length x >= String.length name + && case_unsensitive_eq (String.sub x 0 (String.length name)) name then + let i = + loop (String.length name) where rec loop i = + if i = String.length x then i + else if x.[i] = stop_char then i + else loop (i + 1) + in + String.sub x (String.length name) (i - String.length name) + else extract_param name stop_char l + | [] -> "" ] +; + +value buff = ref (String.create 80); +value store len x = + do if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + return succ len +; +value get_buff len = String.sub buff.val 0 len; + +value get_request strm = + let rec loop len = + parser + [ [: `'\n'; s :] -> + if len == 0 then [] + else let str = get_buff len in [str :: loop 0 s] + | [: `'\r'; s :] -> loop len s + | [: `c; s :] -> loop (store len c) s + | [: :] -> if len == 0 then [] else [get_buff len] ] + in + loop 0 strm +; + +ifdef UNIX then +value timeout tmout spid _ = + do Unix.kill spid Sys.sigkill; + html (); + wprint "Time out\n"; + wprint "

    Time out

    \n"; + wprint "Computation time > %d second(s)\n" tmout; + wprint "\n"; + wflush (); + return exit 2 +; + +value get_request_and_content strm = + let request = get_request strm in + let content = + match extract_param "content-length: " ' ' request with + [ "" -> "" + | x -> + let str = String.create (int_of_string x) in + do for i = 0 to String.length str - 1 do + str.[i] := + match strm with parser + [ [: `x :] -> x + | [: :] -> ' ' ]; + done; + return str ] + in + (request, content) +; + +value string_of_sockaddr = + fun + [ ADDR_UNIX s -> s + | ADDR_INET a _ -> string_of_inet_addr a ] +; +value sockaddr_of_string s = ADDR_UNIX s; + +module W = Map.Make (struct type t = string ; value compare = compare; end); +value who = ref W.empty; +value excluded = ref []; + +value is_robot robot_excluder addr = + match robot_excluder with + [ Some (max_call, sec) -> + let str = string_of_sockaddr addr in + if List.mem str excluded.val then True + else + let tm = Unix.time () in + let r = try W.find str who.val with [ Not_found -> [] ] in + let (cnt, r) = + count r where rec count = + fun + [ [t :: tl] -> + if tm -. t < float sec then + let (cnt, tl) = count tl in (cnt + 1, [t :: tl]) + else (0, []) + | [] -> (0, []) ] + in + do who.val := W.add str [tm :: r] who.val; return + if cnt > max_call then + let str1 = + match addr with + [ ADDR_UNIX s -> s + | ADDR_INET a _ -> + try (gethostbyaddr a).h_name with _ -> + string_of_inet_addr a ] + in +do Printf.eprintf "*** %s is a robot => access definitively refused\n" str1; flush Pervasives.stderr; return + do excluded.val := [str :: excluded.val]; return True + else False + | _ -> False ] +; + +value robot_error t = +ifdef UNIX then + match fork () with + [ 0 -> + do if fork () <> 0 then exit 0 else (); + dup2 t stdout; + wprint "HTTP/1.0 403 Forbidden"; nl (); + wprint "Content-type: text/html; charset=iso-8859-1"; nl (); + nl (); + wprint "

    Access refused

    "; nl (); + wflush (); + try shutdown t SHUTDOWN_SEND with _ -> (); + try shutdown t SHUTDOWN_RECEIVE with _ -> (); + try close t with _ -> (); + exit 2; + return () + | pid -> + let _ = waitpid [] pid in close t ] +else () +; + +value treat_connection tmout callback addr ic = + do ifdef UNIX then + if tmout > 0 then + let spid = fork () in + if spid > 0 then + do let _ : Sys.signal_behavior = + Sys.signal Sys.sigalrm + (Sys.Signal_handle (timeout tmout spid)) + in (); + let _ = alarm tmout in (); + let _ = Unix.waitpid [] spid in (); + let _ : Sys.signal_behavior = + Sys.signal Sys.sigalrm Sys.Signal_default + in (); + exit 0; + return () + else () + else () + else (); + return + let strm = Stream.of_channel ic in + let (request, content) = get_request_and_content strm in + let str = + match extract_param "GET /" ' ' request with + [ "" -> + match extract_param "POST /" ' ' request with + [ "" -> "" + | str -> str ^ "?" ^ content ] + | str -> str ] + in + if str = "robots.txt" then + do wprint "HTTP/1.0 200 Ok"; nl (); + wprint "Content-type: text/plain"; nl (); nl (); + wprint "User-Agent: *"; nl (); + wprint "Disallow: /"; nl (); + wflush (); + Printf.eprintf "Robot request\n"; + flush Pervasives.stderr; + return () + else + let _ = ifdef UNIX then nice 1 else () in + do try callback (addr, request) str with exc -> print_err_exc exc; + try wflush () with _ -> (); + try flush Pervasives.stderr with _ -> (); + return () +; + +value buff = String.create 1024; + +ifdef WIN95 then +value copy_what_necessary t oc = + let strm = + let len = ref 0 in + let i = ref 0 in + Stream.from + (fun _ -> + do if i.val >= len.val then + do len.val := read t buff 0 (String.length buff); + i.val := 0; + if len.val > 0 then output oc buff 0 len.val else (); + return () + else (); + return + if len.val == 0 then None + else do incr i; return Some buff.[i.val - 1]) + in + let _ = get_request_and_content strm in + () +; + +value rec list_remove x = + fun + [ [] -> failwith "list_remove" + | [y :: l] -> if x = y then l else [y :: list_remove x l] ] +; + +value pids = ref []; +value cleanup_sons () = + List.iter + (fun p -> + let (pid, _) = Unix.waitpid [WNOHANG] p in + if pid = 0 then () + else pids.val := list_remove pid pids.val) + pids.val +; + +value accept_connection tmout max_clients robot_excluder callback s = + do match max_clients with + [ Some m -> + do if List.length pids.val >= m then +let tm = Unix.localtime (Unix.time ()) in +do Printf.eprintf "*** %02d/%02d/%4d %02d:%02d:%02d " tm.Unix.tm_mday (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec; Printf.eprintf "%d clients running; waiting...\n" m; flush Pervasives.stderr; return + let (pid, _) = Unix.wait () in +let tm = Unix.localtime (Unix.time ()) in +do Printf.eprintf "*** %02d/%02d/%4d %02d:%02d:%02d " tm.Unix.tm_mday (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec; Printf.eprintf "ok: place for another client\n"; flush Pervasives.stderr; return + pids.val := list_remove pid pids.val + else (); + if pids.val <> [] then cleanup_sons () else (); + let stop_verbose = ref False in + while pids.val <> [] && select [s] [] [] 15.0 = ([], [], []) do + cleanup_sons (); + if pids.val <> [] && not stop_verbose.val then + do stop_verbose.val := True; return + let tm = Unix.localtime (Unix.time ()) in +do Printf.eprintf "*** %02d/%02d/%4d %02d:%02d:%02d %d process(es) remaining after cleanup\n" tm.Unix.tm_mday (succ tm.Unix.tm_mon) (1900 + tm.Unix.tm_year) tm.Unix.tm_hour tm.Unix.tm_min tm.Unix.tm_sec (List.length pids.val); flush Pervasives.stderr; return () + else (); + done; + return () + | None -> () ]; + return + let (t, addr) = accept s in + do setsockopt t SO_KEEPALIVE True; return + if is_robot robot_excluder addr then robot_error t else + ifdef UNIX then + match try Some (fork ()) with _ -> None with + [ Some 0 -> + do try + do if max_clients = None && fork () <> 0 then exit 0 else (); + close s; + dup2 t stdout; + dup2 t stdin; + treat_connection tmout callback addr Pervasives.stdin; + try close t with _ -> (); + return () + with exc -> + try do print_err_exc exc; flush Pervasives.stderr; return () + with _ -> (); + return exit 0 + | Some id -> + do close t; + if max_clients = None then let _ = waitpid [] id in () + else pids.val := [id :: pids.val]; + return () + | None -> + do close t; Printf.eprintf "Fork failed\n"; flush Pervasives.stderr; + return () ] + else + do let oc = open_out_bin "gwd.sin" in + let cleanup () = try close_out oc with _ -> () in + do try copy_what_necessary t oc with + [ Unix_error _ _ _ -> () + | exc -> do cleanup (); return raise exc ]; + cleanup (); + return (); + return + let pid = + let env = + Array.append (Unix.environment ()) + [| "WSERVER=" ^ string_of_sockaddr addr |] + in + Unix.create_process_env Sys.argv.(0) Sys.argv env stdin stdout stderr + in + let _ = Unix.waitpid [] pid in + let cleanup () = + do try shutdown t SHUTDOWN_SEND with _ -> (); + try shutdown t SHUTDOWN_RECEIVE with _ -> (); + try close t with _ -> (); + return () + in + do try + let ic = open_in_bin "gwd.sou" in + let cleanup () = try close_in ic with _ -> () in + do try + loop () where rec loop () = + let len = input ic buff 0 (String.length buff) in + if len == 0 then () + else + do loop_write 0 where rec loop_write i = + let olen = write t buff i (len - i) in + if i + olen < len then loop_write (i + olen) else (); + return loop () + with + [ Unix.Unix_error _ _ _ -> () + | exc -> do cleanup (); return raise exc ]; + cleanup (); + return () + with + [ Unix.Unix_error _ _ _ -> () + | exc -> do cleanup (); return raise exc ]; + cleanup (); + return () +; + +value f port tmout max_clients robot_excluder g = + match try Some (Sys.getenv "WSERVER") with [ Not_found -> None ] with + [ Some s -> + let addr = sockaddr_of_string s in + let ic = open_in_bin "gwd.sin" in + let oc = open_out_bin "gwd.sou" in + do wserver_oc.val := oc; + treat_connection tmout g addr ic; + return exit 0 + | None -> + let s = socket PF_INET SOCK_STREAM 0 in + do setsockopt s SO_REUSEADDR True; + bind s (ADDR_INET inet_addr_any port); + listen s 4; + return + let tm = localtime (time ()) in + do Printf.eprintf "Ready %02d/%02d/%4d %02d:%02d port %d...\n" + tm.tm_mday (succ tm.tm_mon) (1900 + tm.tm_year) tm.tm_hour + tm.tm_min port; + flush Pervasives.stderr; + while True do + try accept_connection tmout max_clients robot_excluder g s with + [ Unix.Unix_error _ "accept" _ -> () + | exc -> print_err_exc exc ]; + wflush (); + flush Pervasives.stdout; + flush Pervasives.stderr; + done; + return () ] +; diff --git a/wserver/wserver.mli b/wserver/wserver.mli new file mode 100644 index 0000000000..1b6adb9980 --- /dev/null +++ b/wserver/wserver.mli @@ -0,0 +1,73 @@ +(* $Id: wserver.mli,v 1.1 1998-09-01 14:32:14 ddr Exp $ *) + +(* module [Wserver]: elementary web service *) + +value f : + int -> int -> option int -> option (int * int) -> + ((Unix.sockaddr * list string) -> string -> unit) -> unit +; + (* [Wserver.f port tmout maxc robot_xcl g] starts an elementary httpd + server at port [port] in the current machine. The port number is any + number greater than 1024 (to create a client < 1024, you must be + root). At each connection, the function [g] is called: + [g (addr, request) s] where [addr] is the client + identification socket, [request] the browser request, and [s] + the string request itself (extracted from [request]). The function + [g] has [tmout] seconds to answer some text on standard output. + If [maxc] is [Some n], maximum [n] clients can be treated at the + same time; [None] means no limit. See the example below. + If [robot_xcl] is [Some (cnt, sec)], robots attacks are excluded, + i.e. connexions calling more than [cnt] request in [sec] consecutive + seconds; if [None], no robot exclusion. *) + +value wprint : format 'a out_channel unit -> 'a; + (* To be called to print page contents. *) + +value wflush : unit -> unit; + (* To flush page contents print. *) + +value html : unit -> unit; + (* [Wserver.html ()] specifies that the text will be HTML. *) + +value encode : string -> string; + (* [Wserver.encode s] encodes the string [s] in another string + where spaces and special characters are coded. This allows + to put such strings in html links . This is + the same encoding done by Web browsers in forms. *) + +value decode : string -> string; + (* [Wserver.decode s] does the inverse job than [Wserver.code], + restoring the initial string. *) + +value extract_param : string -> char -> list string -> string; + (* [extract_param name stopc request] can be used to extract some + parameter from a browser [request] (list of strings); [name] + is a string which should match the beginning of a request line, + [stopc] is a character ending the request line. For example, the + string request has been obtained by: [extract_param "GET /" ' ']. + Answers the empty string if the parameter is not found. *) + +(* Example: + + - Source program "foo.ml": + Wserver.f 2368 60 0 + (fun _ s -> Wserver.html (); Printf.printf "You said: %s...\n" s);; + - Compilation: + ocamlc -custom unix.cma -cclib -lunix wserver.cmo foo.ml + - Run: + ./a.out + - Launch a Web browser and open the location: + http://localhost:2368/hello (but see the remark below) + - You should see a new page displaying the text: + You said: hello... + + Possible problem: if the browser says that it cannot connect to + "localhost:2368", + try: + "localhost.domain:2368" (the domain where your machine is) + "127.0.0.1:2368" + "machine:2368" (your machine name) + "machine.domain:2368" (your machine name) + "addr:2368" (your machine internet address) + +*)