Project

General

Profile

Statistics
| Branch: | Revision:

cool / src / lib / CoAlgLogicUtils.ml @ 7c4d2eb4

History | View | Annotate | Download (2.21 KB)

1

    
2

    
3
open Graph
4

    
5
open CoAlgMisc
6
open CoolUtils
7

    
8
let disjointAgents sort a b =
9
    assert (lfGetType sort a = EnforcesF || lfGetType sort a = AllowsF);
10
    assert (lfGetType sort b = EnforcesF || lfGetType sort b = AllowsF);
11
    let la = lfGetDestAg sort a in
12
    let lb = lfGetDestAg sort b in
13
    let res = ref (true) in
14
    let f idx =
15
        if (TArray.elem idx lb) then res := false
16
        else ()
17
    in
18
    Array.iter f la;
19
    !res
20

    
21
(* Maximal Clique finding *)
22
(* Using algorithm implementation from
23
   http://mancoosi.org/~abate/finding-maximal-cliques-and-independent-sets-undirected-graph-bron%E2%80%93kerbosch-algorithm
24
   which implements http://en.wikipedia.org/wiki/Bron%E2%80%93Kerbosch_algorithm
25
   *)
26

    
27
module V = struct
28
  type t = int
29
  let compare = compare
30
  let hash = Hashtbl.hash
31
  let equal = (=)
32
end
33

    
34
module UG = Persistent.Graph.Concrete(V)
35
module N = Oper.Neighbourhood(UG)
36
module S = N.Vertex_Set
37

    
38
let rec bronKerbosch2 gr r p x =
39
  let n v = N.set_from_vertex gr v in
40
  if (S.is_empty p) && (S.is_empty x) then [r]
41
  else
42
    let u = S.choose (S.union p x) in
43
    let (_,_,mxc) =
44
      S.fold (fun v (p,x,acc) ->
45
        let r' = S.union r (S.singleton v) in
46
        let p' = S.inter p (n v) in
47
        let x' = S.inter x (n v) in
48
        (S.remove v p, S.add v x,(bronKerbosch2 gr r' p' x') @ acc)
49
      ) (S.diff p (n u)) (p,x,[])
50
    in mxc
51

    
52
(* thanks to stackoverflow for cartesian product of lists *)
53
let cartesian l l' = 
54
  List.concat (List.map (fun e -> List.map (fun e' -> (e,e')) l') l)
55

    
56
let maxDisjoints sort (a: bset) : bset list =
57
    let vl = bsetFold (fun x l -> (lfToInt x):: l) a [] in
58
    let gr = List.fold_left (fun g v -> UG.add_vertex g v) UG.empty vl in
59
    let edges = List.filter
60
                    (fun (x,y) -> disjointAgents sort (lfFromInt x) (lfFromInt y))
61
                    (cartesian vl vl)
62
    in
63
    let gr = List.fold_left (fun g (x,y) -> UG.add_edge g x y) gr edges in
64
    let r = S.empty in
65
    let p = List.fold_right S.add vl S.empty in
66
    let x = S.empty in
67
    let intlist = bronKerbosch2 gr r p x in
68
    let tmpf : bset -> int -> bset =
69
        (fun bs f -> bsetAdd bs (lfFromInt f) ; bs)
70
    in
71
    List.map (List.fold_left tmpf (bsetMake ()))
72
             (List.map S.elements intlist)
73

    
74

    
75