## cool / src / lib / CoAlgLogicUtils.ml @ de84f40d

History | View | Annotate | Download (3.58 KB)

1 | |
---|---|

2 | |

3 |
open Graph |

4 | |

5 |
open CoAlgMisc |

6 |
open CoolUtils |

7 |
module L = List |

8 | |

9 |
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 |
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 |
if (TArray.elem idx lb) then res := false |

28 |
else () |

29 |
in |

30 |
Array.iter f la; |

31 |
(* |

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 |
!res |

37 | |

38 |
(* 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 |
(* |

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 |
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 |
(* |

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 |
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 | |

105 |
let string_of_coalition sort bs = |

106 |
let modlist = bsetFold (fun x l -> x::l) bs [] in |

107 |
let modlist = List.map (string_of_cl_modality sort) modlist in |

108 |
"{ " ^ (String.concat ", " modlist) ^ " }" |

109 | |

110 | |

111 |
let string_of_coalition_list sort bs_list = |

112 |
String.concat "\n" (List.map (string_of_coalition sort) bs_list) |

113 |