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