Skip to content

Commit fceefa7

Browse files
author
Ioana
committed
quarks in rules
1 parent 0774db4 commit fceefa7

File tree

9 files changed

+175
-105
lines changed

9 files changed

+175
-105
lines changed

‎ast.ml‎

Lines changed: 143 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,22 +16,160 @@ type agent = (string * port list)
1616

1717
type mixture = agent list
1818

19+
type lnk_or_int = INT of string
20+
| LNK of link
21+
22+
type q = int*string*lnk_or_int
23+
24+
type quarks = Tested of q list
25+
| TestedMod of (q*q) list
26+
| Modified of q list
27+
1928
type rule = {
2029
lhs: mixture ;
21-
bidirectional:bool ;
30+
bidirectional: bool ;
2231
rhs: mixture ;
32+
prefix_map : quarks list;
2333
}
2434
type t = INIT of mixture
2535
| OBS of string*mixture
2636
| RULE of string*rule
2737

38+
39+
let add_free_to_port_lnk plinks = match plinks with
40+
| [] -> [FREE]
41+
| ls -> ls
42+
43+
let add_free_to_mix mix =
44+
List.map
45+
(fun (n,pl) ->
46+
let pl' =
47+
List.map
48+
(fun p ->
49+
let p_lnks= add_free_to_port_lnk p.port_lnk in
50+
{port_nme=p.port_nme;port_int=p.port_int; port_lnk=p_lnks}) pl in
51+
(n,pl')) mix
52+
53+
let split_ports_quarks count port =
54+
let quark_int = match port.port_int with
55+
| [] -> []
56+
| s::_ -> [(count,port.port_nme,(INT s))] in
57+
match port.port_lnk with
58+
| [] -> []
59+
| l::_ -> (count,port.port_nme,(LNK l))::quark_int
60+
61+
let create_quarks mixture count =
62+
List.fold_left
63+
(fun (qs,agent_names,count) (name,plist) ->
64+
let qs' =
65+
List.fold_left
66+
(fun acc port -> (split_ports_quarks count port)@acc) [] plist in
67+
(qs'@qs,(name,count)::agent_names,count+1))
68+
([],[],count) mixture
69+
70+
let create_rhs_quarks agent_names mixture =
71+
let rec aux qs mixt count ag_nm =
72+
match mixt with
73+
| (name,plist)::mixt' ->
74+
if (List.mem (name,count) ag_nm) then
75+
let qs' =
76+
List.fold_left
77+
(fun acc port -> (split_ports_quarks count port)@acc) [] plist in
78+
aux (qs'@qs) mixt' (count+1) ag_nm
79+
else
80+
let (qs',ag_nm',_) = create_quarks mixt' (List.length ag_nm) in
81+
(qs'@qs, ag_nm'@ag_nm)
82+
| [] -> (qs, []) in
83+
aux [] mixture 0 agent_names
84+
85+
let match_il il il' = match (il,il') with
86+
| (INT _,INT _) | (LNK _,LNK _) -> true
87+
| _ -> false
88+
89+
let remove_quark (n,p,il) ls =
90+
List.filter
91+
(fun (n',p',il') ->
92+
(not((n=n')&&(String.equal p p')&&(match_il il il')))) ls
93+
94+
let partition_quarks lhs_quarks rhs_quarks =
95+
let find (n,p,il) rhs =
96+
List.find (fun (n',p',il') ->
97+
(n=n')&&(String.equal p p')&&(match_il il il')) rhs in
98+
let (tested,tested_mod,rhs)=
99+
List.fold_left
100+
(fun (tested,tested_mod,rhs) (n,p,il) ->
101+
if (List.mem (n,p,il) rhs_quarks) then
102+
(((n,p,il)::tested),tested_mod,(remove_quark (n,p,il) rhs))
103+
else
104+
let (n',p',il') =
105+
(try (find (n,p,il) rhs)
106+
with _ ->
107+
(raise
108+
(ExceptionDefn.Syntax_Error
109+
("agent does not have the same ports in lhs and rhs")))) in
110+
(tested,((n,p,il),(n',p',il'))::tested_mod,
111+
(remove_quark (n,p,il) rhs)))
112+
([],[],rhs_quarks) lhs_quarks in
113+
let () =
114+
List.iter (fun (ag,_,_) ->
115+
List.iter
116+
(fun (ag',_,_) ->
117+
if (ag=ag') then
118+
(raise
119+
(ExceptionDefn.Syntax_Error
120+
("agent does not have the same ports
121+
in lhs and rhs")))) rhs)
122+
tested in
123+
(tested,tested_mod,rhs)
124+
125+
let create_prefix_map lhs rhs =
126+
let (lhs_quarks,lhs_agent_nm,_) = create_quarks lhs 0 in
127+
let (rhs_quarks,rhs_agent_nm) = create_rhs_quarks lhs_agent_nm rhs in
128+
let (t_quarks,tm_quarks,m_quarks) =
129+
partition_quarks lhs_quarks rhs_quarks in
130+
[Tested t_quarks; TestedMod tm_quarks; Modified m_quarks]
131+
132+
let clean_rules = function
133+
| INIT mix -> INIT (add_free_to_mix mix)
134+
| OBS (name,mix) -> OBS (name,add_free_to_mix mix)
135+
| RULE (name,r) ->
136+
let () = if (r.bidirectional) then
137+
(raise (ExceptionDefn.Not_Supported
138+
("bidirectional rules not supported"))) in
139+
let lhs = add_free_to_mix r.lhs in
140+
let rhs = add_free_to_mix r.rhs in
141+
let r' = {lhs; bidirectional=r.bidirectional;rhs;
142+
prefix_map = (create_prefix_map lhs rhs)} in
143+
RULE (name,r')
144+
28145
let print_link = function
29146
| LNK_VALUE i -> Format.printf "!%d" i
30-
| FREE -> ()
147+
| FREE -> Format.printf "free"
31148
| LNK_ANY -> Format.printf "!_"
32149
| LNK_SOME -> Format.printf "!_"
33150
| LNK_TYPE (i,a) -> Format.printf "!%s.%s" i a
34151

152+
let print_quarks qs =
153+
let print_q (n,p,il) =
154+
Format.printf "(%d,%s," n p;
155+
(match il with
156+
INT i -> Format.printf "int=%s " i
157+
| LNK lnk ->
158+
Format.printf "lnk= "; print_link lnk);
159+
Format.printf ")" in
160+
let print_qlist qlist =
161+
List.iter (fun q -> print_q q) qlist in
162+
match qs with
163+
| Tested qlist ->
164+
Format.printf "\nTested: "; print_qlist qlist
165+
| Modified qlist ->
166+
Format.printf "\nModified: "; print_qlist qlist
167+
|TestedMod qqlist ->
168+
Format.printf "\nTestedMod ";
169+
List.iter (fun (q1,q2) ->
170+
Format.printf"[before = ";print_q q1;Format.printf "] ";
171+
Format.printf"[after = ";print_q q2;Format.printf "] ") qqlist
172+
35173
let print_port p =
36174
Format.printf "%s~[" p.port_nme;
37175
List.iter (fun intern -> Format.printf "%s " intern;) p.port_int;
@@ -47,15 +185,16 @@ let print_rule r =
47185
List.iter (fun a -> print_agent a) r.lhs;
48186
if (r.bidirectional) then Format.printf " <-> "
49187
else Format.printf " -> ";
50-
List.iter (fun a -> print_agent a) r.rhs
188+
List.iter (fun a -> print_agent a) r.rhs;
189+
List.iter (fun quarks -> print_quarks quarks) r.prefix_map
51190

52191
let print = function
53192
| INIT mix -> Format.printf "\n init "; List.iter (fun a -> print_agent a) mix
54193
| OBS (name,mix) -> Format.printf "\n obs '%s' " name;
55194
List.iter (fun a -> print_agent a) mix
56195
| RULE (name,r) -> Format.printf "\n rule '%s' " name; print_rule r
57196

58-
let empty_rule = {lhs =[];rhs=[];bidirectional=false}
197+
let empty_rule = {lhs =[];rhs=[];bidirectional=false;prefix_map=[]}
59198

60199
let empty = RULE ("empty",empty_rule)
61200

‎ast.mli‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,11 +16,21 @@ type agent = (string * port list)
1616

1717
type mixture = agent list
1818

19+
type lnk_or_int = INT of string
20+
| LNK of link
21+
22+
type q = int*string*lnk_or_int
23+
24+
type quarks = Tested of q list
25+
| TestedMod of (q*q) list
26+
| Modified of q list
1927
type rule = {
2028
lhs: mixture ;
2129
bidirectional:bool ;
2230
rhs: mixture ;
31+
prefix_map : quarks list ;
2332
}
33+
2434
type t = INIT of mixture
2535
| OBS of string*mixture
2636
| RULE of string*rule
@@ -30,6 +40,10 @@ val empty : t
3040
val print_port : port -> unit
3141
val print : t -> unit
3242

43+
(* the parser returns the empty list for a free link
44+
we replace the empty list in link with [FREE] *)
45+
val clean_rules : t -> t
46+
3347
val get_label : t -> String.t
3448
val get_rule_by_label : String.t -> t list -> t
3549

‎event.ml‎

Lines changed: 3 additions & 76 deletions
Original file line numberDiff line numberDiff line change
@@ -1,17 +1,10 @@
11
open Yojson
22
open Lib
33

4-
(*module IntMap = Map.Make(struct type t = int let compare = compare end)*)
5-
6-
type quark =
7-
| Tested of (int*int*int)
8-
| Modified of (int*int*int)
9-
| TestedMod of (int*int*int)
10-
114
type t = {
125
event_id : int; (* local id inside a story *)
136
event_label : string;
14-
quarks : quark list;
7+
quarks : Quark.t list;
158
}
169

1710
let get_id e = e.event_id
@@ -24,27 +17,6 @@ let test_event event_id event_label =
2417
let print_event e =
2518
Format.printf " (%i, %s) " (e.event_id) (e.event_label)
2619

27-
let quarks_of_json (quarks:Yojson.Basic.json) =
28-
let open Yojson.Basic.Util in
29-
match quarks with
30-
| `List [`String impact; (`Assoc ["node", `Int node]);
31-
(`Assoc ["site", `Int site]); `String state] ->
32-
let state_int = match state with
33-
| "link" -> 1
34-
| "internal state" -> 0
35-
| x -> raise (Yojson.Basic.Util.Type_error
36-
("Not in the cflow format for link/internal state ",
37-
`String x))
38-
in
39-
(match impact with
40-
| "tested" -> Tested (node,site,state_int)
41-
| "modified" -> Modified (node,site,state_int)
42-
| "tested + modified" -> TestedMod (node,site,state_int)
43-
| x -> raise (Yojson.Basic.Util.Type_error
44-
("Not in the cflow format for quarks",`String x)))
45-
| _ -> raise (Yojson.Basic.Util.Type_error
46-
("Not in the cflow format for quarks",`Null))
47-
4820
let nodes_of_json (node:Yojson.Basic.json) =
4921
let open Yojson.Basic.Util in
5022
match node with
@@ -55,7 +27,7 @@ let nodes_of_json (node:Yojson.Basic.json) =
5527
| `List [`Int id; `String "PERT"; `String label;
5628
(`Assoc ["quarks", `List l])]->
5729
let quarks_ls =
58-
List.map (fun q -> quarks_of_json q) l in
30+
List.map (fun q -> Quark.quarks_of_json q) l in
5931
{ event_id = id; event_label = label; quarks = quarks_ls; }
6032
| `List [`Int id; `String "INIT"; `List l;
6133
(`Assoc ["quarks", `List ql])] ->
@@ -67,51 +39,6 @@ let nodes_of_json (node:Yojson.Basic.json) =
6739
| x -> raise (Yojson.Basic.Util.Type_error
6840
("Not in the cflow format",x))) "" l in
6941
let quarks_ls =
70-
List.map (fun q -> quarks_of_json q) ql in
42+
List.map (fun q -> Quark.quarks_of_json q) ql in
7143
{ event_id = id; event_label = init_label; quarks = quarks_ls; }
7244
| _ -> raise (Yojson.Basic.Util.Type_error ("Not in the cflow format",`Null))
73-
74-
let quarks_tested qs =
75-
List.filter (function
76-
Tested _ -> true
77-
| Modified _ | TestedMod _ -> false) qs
78-
79-
let quarks_testedMod qs =
80-
List.filter (function
81-
TestedMod _ -> true
82-
| Modified _ | Tested _ -> false) qs
83-
84-
let quarks_modified qs =
85-
List.filter (function
86-
Modified _ -> true
87-
| Tested _ | TestedMod _ -> false) qs
88-
89-
let get_nodes qs =
90-
List.fold_left
91-
(fun nodes -> function
92-
| Modified (ni,pi,il)| Tested (ni,pi,il)| TestedMod (ni,pi,il) ->
93-
if (List.mem ni nodes) then nodes else ni::nodes) [] qs
94-
95-
let get_nodes_ports qs =
96-
let n = List.length (get_nodes qs) in
97-
let myhash = Hashtbl.create n in
98-
99-
let build_port_list n p qs =
100-
let (qs_np,rest)=
101-
List.partition
102-
(function
103-
| Modified (ni,pi,_)| Tested (ni,pi,_)| TestedMod (ni,pi,_) ->
104-
(n=ni)&&(p=pi)) qs in
105-
let plist =
106-
List.map
107-
(function Modified t| Tested t| TestedMod t -> Lib.thd t) qs_np in
108-
(plist,rest) in
109-
110-
let rec build_map qs = match qs with
111-
| [] -> myhash
112-
| q::rs -> match q with
113-
| Modified (ni,pi,_)| Tested (ni,pi,_)| TestedMod (ni,pi,_) ->
114-
let (port,rest) = build_port_list ni pi qs in
115-
let () = if (pi >= 0) then Hashtbl.add myhash ni (pi,port) in
116-
build_map rest in
117-
build_map qs

‎event.mli‎

Lines changed: 2 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -1,29 +1,16 @@
11
open Yojson
22

3-
(*module IntMap : Map.S with type key = int*)
4-
5-
type quark =
6-
| Tested of (int*int*int)
7-
| Modified of (int*int*int)
8-
| TestedMod of (int*int*int)
9-
103
type t = {
114
event_id : int; (* local id inside a story *)
125
event_label : string;
13-
quarks : quark list;
6+
quarks : Quark.t list;
147
}
158

169
val nodes_of_json : Yojson.Basic.json -> t
1710

1811
val get_id : t -> int
1912
val get_label : t -> string
20-
val get_quarks : t -> quark list
13+
val get_quarks : t -> Quark.t list
2114

2215
val print_event : t -> unit
2316
val test_event : int -> string -> t
24-
25-
val quarks_tested : quark list -> quark list
26-
val quarks_testedMod : quark list -> quark list
27-
val quarks_modified : quark list -> quark list
28-
val get_nodes : quark list -> int list
29-
val get_nodes_ports : quark list -> (int, (int*int list)) Hashtbl.t

‎grammar/lexerRule.mll‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -41,7 +41,7 @@ rule token = parse
4141
match lab with
4242
| "init" -> INIT
4343
| "obs" -> OBS
44-
| _ as s ->
44+
| _ ->
4545
raise (ExceptionDefn.Syntax_Error("invalid use of %"))}
4646
| '!' {KAPPA_LNK}
4747
| internal_state as s {let i = String.index s '~' in

‎grammar/parserRule.mly‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,7 @@ start_rule:
2424
rule_expression:
2525
| rule_label lhs_rhs arrow lhs_rhs
2626
{ Ast.RULE ($1,({Ast.lhs=$2; Ast.bidirectional=$3;
27-
Ast.rhs=$4;}))}
27+
Ast.rhs=$4;Ast.prefix_map=[]}))}
2828
;
2929

3030
arrow:

‎main.ml‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,8 @@ let parse_rules () =
6161
let lexbuf = Lexing.from_channel chan in
6262
while true do
6363
let result = ParserRule.newline LexerRule.token lexbuf in
64-
read_rule := result::(!read_rule);
64+
let free_res = Ast.clean_rules result in
65+
read_rule := free_res::(!read_rule);
6566
if (!Parameter.debug_mode) then
6667
(Format.printf "parsing \n"; Ast.print result;Format.printf"\n")
6768
done
@@ -107,6 +108,7 @@ let () =
107108
Formulas.Var "s2"]))) in
108109

109110
let m = Formulas.interpretation posets (!read_rule) in
111+
let () = Format.printf "print the rules: " in
110112
let () = Format.printf "\n evaluate formula:\n" in
111113
(evaluate fm_neg m empty_valuation)
112114

0 commit comments

Comments
 (0)