1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
type t = {
roots: Roots.t;
}
type message = unit
let receive_message _ st = st
let empty env = { roots = Roots.empty env }
let state pattern matchings =
Roots.incorporate_extra_pattern state.roots pattern matchings
let break_apart_cc state edges ?mod_connectivity_store ccs =
Roots.break_apart_cc state.roots edges ?mod_connectivity_store ccs
let merge_cc state ?mod_connectivity_store ccs =
Roots.merge_cc state.roots ?mod_connectivity_store ccs
let update_roots state is_add unary_ccs edges mod_connectivity pattern root =
Roots.update_roots state.roots is_add unary_ccs edges mod_connectivity pattern
root
(** {2 Checking instances} *)
let is_valid state pat root =
IntCollection.mem root (Roots.of_pattern pat state.roots)
(** {2 Compute the number of instances } *)
let number_of_instances ?rule_id:_ st pats =
Array.fold_left
(fun acc pattern -> acc * Roots.number st.roots pattern)
1 pats
let number_of_unary_instances_in_cc ?rule_id:_ st (pat1, pat2) =
let map1 = Roots.of_unary_pattern pat1 st.roots in
let map2 = Roots.of_unary_pattern pat2 st.roots in
fun cc ->
let set1 = Mods.IntMap.find_default Mods.IntSet.empty cc map1 in
let set2 = Mods.IntMap.find_default Mods.IntSet.empty cc map2 in
Mods.IntSet.size set1 * Mods.IntSet.size set2
let pick_unary_instance_in_cc ?rule_id:_ st random_state (pat1, pat2) =
let map1 = Roots.of_unary_pattern pat1 st.roots in
let map2 = Roots.of_unary_pattern pat2 st.roots in
fun cc ->
let root1 =
Option_util.unsome (-1)
(Mods.IntSet.random random_state
(Mods.IntMap.find_default Mods.IntSet.empty cc map1))
in
let root2 =
Option_util.unsome (-1)
(Mods.IntSet.random random_state
(Mods.IntMap.find_default Mods.IntSet.empty cc map2))
in
root1, root2
let fold_picked_instance ?rule_id:_ st random_state pats ~init f =
let rec aux i acc =
if i >= Array.length pats then
acc
else (
match acc with
| None -> None
| Some acc ->
let pat = pats.(i) in
let root_opt =
IntCollection.random random_state (Roots.of_pattern pat st.roots)
in
(match root_opt with
| None -> None
| Some root ->
let acc = f i pat root acc in
aux (i + 1) acc)
)
in
aux 0 (Some init)
(** {6 Enumerate instances} *)
let process_excp =
let no_no_no _ = false in
fun pats -> function
| None -> no_no_no, -1
| Some (pat, root) ->
let sent_to_fixed_root j = Pattern.is_equal_canonicals pat pats.(j) in
sent_to_fixed_root, root
let fold_instances ?rule_id:_ ?excp st pats ~init f =
let sent_to_excp_root, excp_root = process_excp pats excp in
let n = Array.length pats in
let tab = Array.make n (-1) in
let rec aux i acc =
if i >= n then
f tab acc
else if sent_to_excp_root i then (
tab.(i) <- excp_root;
aux (i + 1) acc
) else (
let ith_roots = Roots.of_pattern pats.(i) st.roots in
IntCollection.fold
(fun r acc ->
tab.(i) <- r;
aux (i + 1) acc)
ith_roots acc
)
in
aux 0 init
let map_fold2 map1 map2 ~init f =
Mods.IntMap.monadic_fold2_sparse () ()
(fun () () key x1 x2 acc -> (), f key x1 x2 acc)
map1 map2 init
|> snd
let fold_unary_instances ?rule_id:_ st (pat1, pat2) ~init f =
let map1 = Roots.of_unary_pattern pat1 st.roots in
let map2 = Roots.of_unary_pattern pat2 st.roots in
map_fold2 map1 map2 ~init (fun _ set1 set2 acc ->
Mods.IntSet.fold
(fun root1 acc ->
Mods.IntSet.fold (fun root2 acc -> f (root1, root2) acc) set2 acc)
set1 acc)
(** {6 Debug functions} *)
let debug_print f state = Roots.debug_print f state.roots