Project

General

Profile

Statistics
| Branch: | Revision:

cool / src / lib / CoAlgLogicUtils.ml @ de84f40d

History | View | Annotate | Download (3.58 KB)

1 7369dd14 Thorsten Wißmann
2
3 6fad6e7e Thorsten Wißmann
open Graph
4 7369dd14 Thorsten Wißmann
5
open CoAlgMisc
6 e2dc68f7 Thorsten Wißmann
open CoolUtils
7 77a804ab Thorsten Wißmann
module L = List
8 7369dd14 Thorsten Wißmann
9 77a804ab Thorsten Wißmann
let string_of_cl_modality sort modality =
10
    let (o,c) = (* open/close brackets *)
11
        match lfGetType sort modality with
12
        | EnforcesF -> ("[","]")
13
        | AllowsF -> ("{","}")
14
        | _ -> ("¿","?")
15
    in
16
    let agents = (Array.to_list (lfGetDestAg sort modality)) in
17
    let agents = List.map string_of_int agents in
18
    o^(String.concat ", " agents)^c
19
20
let disjointAgents sort a b : bool =
21 7369dd14 Thorsten Wißmann
    assert (lfGetType sort a = EnforcesF || lfGetType sort a = AllowsF);
22
    assert (lfGetType sort b = EnforcesF || lfGetType sort b = AllowsF);
23
    let la = lfGetDestAg sort a in
24
    let lb = lfGetDestAg sort b in
25
    let res = ref (true) in
26
    let f idx =
27 5e185dd3 Thorsten Wißmann
        if (TArray.elem idx lb) then res := false
28 7369dd14 Thorsten Wißmann
        else ()
29
    in
30
    Array.iter f la;
31 77a804ab Thorsten Wißmann
    (*
32
    let s_o_cl = string_of_cl_modality sort in
33
    let str = (s_o_cl a) ^ " disj. " ^ (s_o_cl b) in
34
    print_endline (str ^ "= " ^ (string_of_bool !res));
35
    *)
36 7369dd14 Thorsten Wißmann
    !res
37
38 a0cffef0 Thorsten Wißmann
(* Maximal Clique finding *)
39
(* Using algorithm implementation from
40
   http://mancoosi.org/~abate/finding-maximal-cliques-and-independent-sets-undirected-graph-bron%E2%80%93kerbosch-algorithm
41
   which implements http://en.wikipedia.org/wiki/Bron%E2%80%93Kerbosch_algorithm
42
   *)
43
44
module V = struct
45
  type t = int
46
  let compare = compare
47
  let hash = Hashtbl.hash
48
  let equal = (=)
49
end
50
51
module UG = Persistent.Graph.Concrete(V)
52
module N = Oper.Neighbourhood(UG)
53
module S = N.Vertex_Set
54
55
let rec bronKerbosch2 gr r p x =
56
  let n v = N.set_from_vertex gr v in
57
  if (S.is_empty p) && (S.is_empty x) then [r]
58
  else
59
    let u = S.choose (S.union p x) in
60
    let (_,_,mxc) =
61
      S.fold (fun v (p,x,acc) ->
62
        let r' = S.union r (S.singleton v) in
63
        let p' = S.inter p (n v) in
64
        let x' = S.inter x (n v) in
65
        (S.remove v p, S.add v x,(bronKerbosch2 gr r' p' x') @ acc)
66
      ) (S.diff p (n u)) (p,x,[])
67
    in mxc
68
69
(* thanks to stackoverflow for cartesian product of lists *)
70
let cartesian l l' = 
71
  List.concat (List.map (fun e -> List.map (fun e' -> (e,e')) l') l)
72
73
let maxDisjoints sort (a: bset) : bset list =
74
    let vl = bsetFold (fun x l -> (lfToInt x):: l) a [] in
75
    let gr = List.fold_left (fun g v -> UG.add_vertex g v) UG.empty vl in
76
    let edges = List.filter
77
                    (fun (x,y) -> disjointAgents sort (lfFromInt x) (lfFromInt y))
78
                    (cartesian vl vl)
79
    in
80 77a804ab Thorsten Wißmann
    (*
81
    let se = String.concat ", " (List.map (fun (x,y) -> (string_of_int x)^"-"^(string_of_int y)) edges) in
82
    print_endline ("Graph: "^se);
83
    *)
84 a0cffef0 Thorsten Wißmann
    let gr = List.fold_left (fun g (x,y) -> UG.add_edge g x y) gr edges in
85
    let r = S.empty in
86
    let p = List.fold_right S.add vl S.empty in
87
    let x = S.empty in
88
    let intlist = bronKerbosch2 gr r p x in
89 77a804ab Thorsten Wißmann
    (*
90
    foreach_l intlist (fun s -> let s = L.map string_of_int (S.elements s) in
91
        print_endline ("Cliqu: "^ String.concat "," s)
92
    );
93
    *)
94 202433a6 Thorsten Wißmann
    flip List.map intlist (fun elements ->
95
        (* for each maximal clique "elements", do: *)
96
        let elements = S.elements elements in (* obtain a list of ints *)
97
        let elements = L.map lfFromInt elements in (* convert them to local formulas *)
98
        (* throw them into a bset *)
99
        let bs = (bsetMakeRealEmpty ()) in
100
        List.iter (bsetAdd bs) elements;
101
        bs
102
    )
103
104 a0cffef0 Thorsten Wißmann
105 26e21f07 Thorsten Wißmann
let string_of_coalition sort bs =
106
    let modlist = bsetFold (fun x l -> x::l) bs [] in
107 77a804ab Thorsten Wißmann
    let modlist = List.map (string_of_cl_modality sort) modlist in
108 26e21f07 Thorsten Wißmann
    "{ " ^ (String.concat ", " modlist) ^ " }"
109
110 a0cffef0 Thorsten Wißmann
111 26e21f07 Thorsten Wißmann
let string_of_coalition_list sort bs_list =
112
    String.concat "\n" (List.map (string_of_coalition sort) bs_list)