142 lines
4.5 KiB
OCaml
142 lines
4.5 KiB
OCaml
open Config
|
|
open Dag2html
|
|
open Def
|
|
open Gwdb
|
|
open Util
|
|
|
|
(* TODO use a set.. *)
|
|
module Pset = struct
|
|
type t = iper list
|
|
type elt = iper
|
|
|
|
let add e s = if List.mem e s then s else e :: s
|
|
let empty = []
|
|
let elements s = List.rev s
|
|
let mem = List.mem
|
|
end
|
|
|
|
(* input dag *)
|
|
|
|
let get_dag_elems conf base =
|
|
let rec loop prev_po set i =
|
|
let s = string_of_int i in
|
|
let po = Util.find_person_in_env conf base s in
|
|
let po = match po with None -> prev_po | x -> x in
|
|
let so = Util.p_getenv conf.env ("s" ^ s) in
|
|
match (po, so) with
|
|
| Some p, Some s ->
|
|
let set =
|
|
match Util.branch_of_sosa conf base (Sosa.of_string s) p with
|
|
| Some ipsl ->
|
|
List.fold_left (fun set p -> Pset.add (get_iper p) set) set ipsl
|
|
| None -> set
|
|
in
|
|
loop po set (i + 1)
|
|
| _ -> set
|
|
in
|
|
loop None Pset.empty 1
|
|
|
|
type ('a, 'b) sum = ('a, 'b) Def.choice
|
|
|
|
let make_dag conf base set =
|
|
let list = Pset.elements set in
|
|
let module O = struct
|
|
type t = iper
|
|
|
|
let compare = compare
|
|
end in
|
|
let module M = Map.Make (O) in
|
|
let nodes = Array.of_list list in
|
|
let map =
|
|
let rec loop map i =
|
|
if i = Array.length nodes then map
|
|
else loop (M.add nodes.(i) (idag_of_int i) map) (i + 1)
|
|
in
|
|
loop M.empty 0
|
|
in
|
|
let nodes =
|
|
Array.map
|
|
(fun ip ->
|
|
let pare =
|
|
match get_parents (pget conf base ip) with
|
|
| Some ifam -> (
|
|
let c = foi base ifam in
|
|
let l =
|
|
try [ M.find (get_mother c) map ] with Not_found -> []
|
|
in
|
|
try M.find (get_father c) map :: l with Not_found -> l)
|
|
| None -> []
|
|
in
|
|
let chil =
|
|
let u = pget conf base ip in
|
|
Array.fold_left
|
|
(fun chil ifam ->
|
|
let des = foi base ifam in
|
|
Array.fold_left
|
|
(fun chil ip ->
|
|
try M.find ip map :: chil with Not_found -> chil)
|
|
chil (get_children des))
|
|
[] (get_family u)
|
|
in
|
|
let chil = List.rev chil in
|
|
{ pare; valu = Left ip; chil })
|
|
nodes
|
|
in
|
|
let nodes =
|
|
let rec loop nodes n i =
|
|
if i = Array.length nodes then nodes
|
|
else
|
|
match nodes.(i) with
|
|
| { valu = Left ip; chil } ->
|
|
let ifaml = Array.to_list (get_family (pget conf base ip)) in
|
|
let nodes, n =
|
|
let rec loop nodes = function
|
|
| ifam :: ifaml -> (
|
|
let cpl = foi base ifam in
|
|
let isp = Gutil.spouse ip cpl in
|
|
let jdo =
|
|
try Some (M.find isp map) with Not_found -> None
|
|
in
|
|
match jdo with
|
|
| Some jd ->
|
|
let j = int_of_idag jd in
|
|
if chil = [] && nodes.(j).chil = [] then (
|
|
let pare = [ idag_of_int i; jd ] in
|
|
let d = { pare; valu = Right n; chil = [] } in
|
|
let nodes = Array.append nodes [| d |] in
|
|
let nd = idag_of_int n in
|
|
nodes.(i).chil <- [ nd ];
|
|
nodes.(j).chil <- [ nd ];
|
|
(nodes, n + 1))
|
|
else if chil <> nodes.(j).chil then (
|
|
List.iter
|
|
(fun nd ->
|
|
if List.mem nd nodes.(j).chil then ()
|
|
else
|
|
let n = int_of_idag nd in
|
|
nodes.(j).chil <- nd :: nodes.(j).chil;
|
|
nodes.(n).pare <- jd :: nodes.(n).pare)
|
|
chil;
|
|
List.iter
|
|
(fun nd ->
|
|
if List.mem nd chil then ()
|
|
else
|
|
let id = idag_of_int i in
|
|
let n = int_of_idag nd in
|
|
nodes.(i).chil <- nd :: chil;
|
|
nodes.(n).pare <- id :: nodes.(n).pare)
|
|
nodes.(j).chil;
|
|
loop nodes ifaml)
|
|
else loop nodes ifaml
|
|
| None -> loop nodes ifaml)
|
|
| [] -> (nodes, n)
|
|
in
|
|
loop nodes ifaml
|
|
in
|
|
loop nodes n (i + 1)
|
|
| _ -> loop nodes n (i + 1)
|
|
in
|
|
loop nodes (Array.length nodes) 0
|
|
in
|
|
{ dag = nodes }
|