(* a relation module parameterized by an ordered type *)
module Relation (T: Set.OrderedType) = struct

module M = Map.Make(T)                (* maps over an ordered type *)
module S = Set.Make(T)                (* sets of an ordered type *)

let comp f g x = f (g x)        (* function composition *)

let fix f =                        (* fixpoint of f starting from x *)
  let rec fix2 x = 
    let y = f x in if y = x then x else fix2 y
  in fix2

(* return set of y related to x in R(x, y) -- "successors" *)
let rels r x = try M.find x r with Not_found -> S.empty

(* like rels, but return {x} U map(x) = element + related ones *)
let optrels m e = S.add e (rels m e)

(* union of mapping f over elements of a set = lift f to sets *)
let setmap f s = S.fold (fun x -> S.union (f x)) s S.empty

(* r2 U r2r1: apply r1 optionally after r2 *)
let rel2opt1 = comp M.map (comp setmap optmap)

(* closure R U R^2 U ... U R^n is fixpoint of F(X) = X U XR *)
let transclose1 r = fix (rel2opt1 r) r

(* r1 U r2, folding r1 into r2 *)
let reladd r1 r2 = M.fold (fun x -> comp (M.add x) (S.union (rels r2 x))) r1 r2

(* r \ rs, computed starting from r *)
let relsub rs = M.mapi (fun x xm -> S.diff xm (rels rs x))

(* r2 composed with r1: \exists y . R2(x, y) /\ R1(y, z) *)
let relcomp21 = comp M.map (comp setmap rels)

(* another version, computes R U ... U R^n and difference R^n \ former *)
let transclose2 r = 
  let uniondiff (un, dn)  =
    let rn1 = relcomp21 r dn in
    let dn1 = relsub un rn1 in (reladd dn1 un, dn1)
  in fst (fix uniondiff (r, r))

(* successor set of a set *)
let succset g s = S.fold (comp S.union (rels g)) s S.empty

(* union of set and its successor *)
let optsuccset g s = S.union s (succset g s)

(* all elements reachable by R^+ *)
let reachset = comp fix optsuccset

let showrel r = List.map (fun (x, y) -> (x, S.elements y)) (M.bindings r)

module R = Relation(String)
open R

let r = M.add "1" (S.singleton "2") (M.add "2" (S.singleton "3") (M.add "3" (S.singleton "4") (M.singleton "4" (S.singleton "5"))))

showrel (transclose1 r);;

showrel (transclose2 r);;

S.elements (reachset r (S.singleton "1"));;

This document was generated using caml2html