+let rec rm_assoc_option n = function
+ | [] -> None,[]
+ | (x,i)::tl when n=x -> Some i,tl
+ | p::tl -> let i,tl = rm_assoc_option n tl in i,p::tl
+;;
+
+let rm_assoc_assert n l =
+ match rm_assoc_option n l with
+ | None,_ -> assert false
+ | Some i,l -> i,l
+;;
+
+(* naif implementation of the union-find merge operation
+ canonicals maps elements to canonicals
+ elements maps canonicals to the classes *)
+let merge canonicals elements extern n m =
+ let cn,canonicals = rm_assoc_option n canonicals in
+ let cm,canonicals = rm_assoc_option m canonicals in
+ match cn,cm with
+ | None, None -> canonicals, elements, extern
+ | None, Some c
+ | Some c, None ->
+ let l,elements = rm_assoc_assert c elements in
+ let canonicals =
+ List.filter (fun (_,xc) -> not (xc = c)) canonicals
+ in
+ canonicals,elements,l@extern
+ | Some cn, Some cm when cn=cm ->
+ (n,cm)::(m,cm)::canonicals, elements, extern
+ | Some cn, Some cm ->
+ let ln,elements = rm_assoc_assert cn elements in
+ let lm,elements = rm_assoc_assert cm elements in
+ let canonicals =
+ (n,cm)::(m,cm)::List.map
+ (fun ((x,xc) as p) ->
+ if xc = cn then (x,cm) else p) canonicals
+ in
+ let elements = (cm,ln@lm)::elements
+ in
+ canonicals,elements,extern
+;;
+
+(* f x gives the direct dependencies of x.
+ x must not belong to (f x).
+ All elements not in l are merged into a single extern class *)
+let clusters f l =
+ let canonicals = List.map (fun x -> (x,x)) l in
+ let elements = List.map (fun x -> (x,[x])) l in
+ let extern = [] in
+ let _,elements,extern =
+ List.fold_left
+ (fun (canonicals,elements,extern) x ->
+ let dep = f x in
+ List.fold_left
+ (fun (canonicals,elements,extern) d ->
+ merge canonicals elements extern d x)
+ (canonicals,elements,extern) dep)
+ (canonicals,elements,extern) l
+ in
+ let c = (List.map snd elements) in
+ if extern = [] then c else extern::c
+;;
+