Property based test for parsing and simplification of structured trees

lib/src/CoAlgFormula.ml

@@ -3,7 +3,6 @@
     @author Florian Widmann
  *)
 
-
 module HC = HashConsing
 module A = AltGenlex
 module L = List
@@ -2538,4 +2537,80 @@ module HcFHt = Hashtbl.Make(
   end
  )
 
+let rec parseFormulaToTree formula =
+  let open CoolUtils.Tree in
+  match formula with
+    | TRUE -> Leaf TRUE
+    | FALSE -> Leaf FALSE
+    | AP a -> Leaf (AP a)
+    | NOT f -> let child = parseFormulaToTree f in 
+        Node ([child], (fun fList -> NOT (List.hd fList)), (getHeight child) + 1)
+    | AT (s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> AT (s, List.hd fList)), (getHeight child) + 1)
+    | OR (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> OR (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | AND (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> AND (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | EQU (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> EQU (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | IMP (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> IMP (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | EX (s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> EX (s, List.hd fList)), (getHeight child) + 1)
+    | AX (s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> AX (s, List.hd fList)), (getHeight child) + 1)
+    | ENFORCES (iL, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> ENFORCES (iL, List.hd fList)), (getHeight child) + 1)
+    | ALLOWS (iL, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> ALLOWS (iL, List.hd fList)), (getHeight child) + 1)
+    | MIN (i, s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> MIN (i, s, List.hd fList)), (getHeight child) + 1)
+    | MAX (i, s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> MAX (i, s, List.hd fList)), (getHeight child) + 1)
+    | MORETHAN (i, s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> MORETHAN (i, s, List.hd fList)), (getHeight child) + 1)
+    | MAXEXCEPT (i, s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> MAXEXCEPT (i, s, List.hd fList)), (getHeight child) + 1)
+    | ATLEASTPROB (r, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> ATLEASTPROB (r, List.hd fList)), (getHeight child) + 1)
+    | LESSPROBFAIL (r, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> LESSPROBFAIL (r, List.hd fList)), (getHeight child) + 1)
+    | CONST s -> Leaf (CONST s)
+    | CONSTN s -> Leaf (CONSTN s)
+    | ID f -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> ID (List.hd fList)), (getHeight child) + 1)
+    | NORM (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> NORM (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | NORMN (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> NORMN (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | CHC (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> CHC (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | FUS (b, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> FUS (b, List.hd fList)), (getHeight child) + 1)
+    | MU (s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> MU (s, List.hd fList)), (getHeight child) + 1)
+    | NU (s, f) -> let child = parseFormulaToTree f in
+        Node ([child], (fun fList -> NU (s, List.hd fList)), (getHeight child) + 1)
+    | VAR s -> Leaf (VAR s)
+    | AF f -> let child = parseFormulaToTree f in 
+        Node ([child], (fun fList -> AF (List.hd fList)), (getHeight child) + 1)
+    | EF f -> let child = parseFormulaToTree f in 
+        Node ([child], (fun fList -> EF (List.hd fList)), (getHeight child) + 1)
+    | AG f -> let child = parseFormulaToTree f in 
+        Node ([child], (fun fList -> AG (List.hd fList)), (getHeight child) + 1)
+    | EG f -> let child = parseFormulaToTree f in 
+        Node ([child], (fun fList -> EG (List.hd fList)), (getHeight child) + 1)
+    | AU (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> AU (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | EU (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> EU (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | AR (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> AR (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | ER (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> ER (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | AB (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> AB (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+    | EB (f1, f2) -> let (child1, child2) = (parseFormulaToTree f1, parseFormulaToTree f2) in
+        Node ([child1; child2], (fun fList -> EB (List.hd fList, List.nth fList 1)), (max (getHeight child1) (getHeight child2)) + 1)
+
 (* vim: set et sw=2 sts=2 ts=8 : *)

lib/src/CoAlgFormula.mli

@@ -188,4 +188,6 @@ val hc_freeIn2 : string -> hcFormula -> bool
 
 module HcFHt : (Hashtbl.S with type key = hcFormula)
 
+val parseFormulaToTree: formula -> formula CoolUtils.Tree.tree
+
 (* vim: set et sw=2 sts=2 ts=8 : *)

lib/src/CoolUtils.ml

@@ -178,6 +178,9 @@ module Tree = struct
     match aTree with
       | Leaf _ -> (expectedHeight = 0)
       | Node (_, _, height) -> (height = expectedHeight)
+  let getHeight aTree = match aTree with
+    | Leaf _ -> 0
+    | Node (_, _, h) -> h
   let rec simplify atree = match atree with
     | Leaf _ -> None
     | Node (aTreeList, func, height) -> 
@@ -190,11 +193,9 @@ module Tree = struct
               match aTree with
                 | Leaf a -> Leaf a
                 | Node (_, _, depth) -> if (depth = maxDepth)
-                    then
-                      begin
-                          foundDeepest := true;
-                          Option.get (simplify aTree)
-                      end
+                    then match simplify aTree with
+                      | None -> aTree
+                      | Some aT -> (foundDeepest := true; aT)
                     else aTree
             in
             let newChildren = 

lib/src/CoolUtils.mli

@@ -106,6 +106,7 @@ module Tree :
 
     val simplify : 'a tree -> 'a tree option
     val parse_back : 'a tree -> 'a
+    val getHeight : 'a tree -> int
   end
 
 (* vim: set et sw=2 sts=2 ts=8 : *)

lib/tests/testsuite/Testsuite.ml

@@ -88,7 +88,7 @@ let make_sorted (list:(F.formula list)) =
   List.map (fun (f:F.formula) -> (0, f)) list
 (* Needs the formula as a sortedTable, sort set to 0 as by default. To be checked what's up with that. *)
 
-let onestepFunc_equals_tableau ?(num_runs = 50) name sized_formula_gen logic =
+let onestepFunc_equals_tableau ?(num_runs = 5) name sized_formula_gen logic =
   "onestep func = tableau" >: to_ounit2_test ~rand: (Random.State.make_self_init ()) (Test.make ~count:num_runs ~name:name
     ( make ~print:F.string_of_formula  (sized sized_formula_gen))  (fun (formula) ->
       (onestepFunc_equals_tableau_predicate logic (0, formula)) ))

lib/tests/testsuite/cool_testsuite.ml

@@ -144,7 +144,7 @@ let k = funel_of_functor CM.MultiModalK
 let prop_onestepFunc_tableau_K = onestepFunc_equals_tableau "K Property" FG.formula_K (FE.sortTableFromFunctorExp k)
 
 let testcases =
-  [ (* "DL98" >::: dl98_testcases
+  [  (*"DL98" >::: dl98_testcases
   ; "CTL" >::: ctl_fast_testcases
   ; "K Tableau" >::: k_testcases false
   ; "K Onestep" >::: k_testcases true

lib/tests/unit_tests/CoAlgFormula_tests.ml

-open OUnit2
+open Cool
 open Cool.CoAlgFormula
+open QCheck
+open QCheck.Gen
+open QCheck_ounit
+open OUnit2
+
+
 
 let isMuAconjunctive_test _ =
   let with_formula str action = action (importFormula str) str in
@@ -9,6 +15,13 @@ let isMuAconjunctive_test _ =
   with_formula "μ x. μ y. ([r] x & <r> y)" (fun f f_str ->
    assert_bool f_str (not (isMuAconjunctive f)))
 
-let tests = "CoAlgFormula" >: ("isMuAconjunctive" >:: isMuAconjunctive_test)
+let treeParserAndSimplify_predicate formula =
+  Some (CoolUtils.Tree.parse_back (CoAlgFormula.parseFormulaToTree formula)) = Some formula
+
+let treeParserAndSimplify_prop =
+  "treeParserAndSimplify" >: to_ounit2_test ~rand:(Random.State.make_self_init ()) (Test.make ~count:10000 ( make (sized Formula_gen.formula_K)) treeParserAndSimplify_predicate)
+
+let tests = "CoAlgFormula" >::: ["isMuAconjunctive" >:: isMuAconjunctive_test; "treeParserAndSimplify" >: treeParserAndSimplify_prop]
+                              
 
 (* vim: set et sw=2 sts=2 ts=8 : *)

lib/tests/unit_tests/dune

@@ -2,6 +2,6 @@
  (name cool_unit_tests)
  (modes native)
  (package cool-lib)
- (libraries cool-lib ounit2)
+ (libraries cool-lib ounit2 qcheck cool-generators)
  (action (run %{test} -output-junit-file unit_tests.xml)))